locked
extact contents from word to excel RRS feed

  • Question

  • Hi,

    I need to extract contents from word to excel, my word document consists of text like this, i have tried out a code, it is not working out, please any one can help


    Chapter 1   Subscribe

     

    CD-PNI-SQT-SSA056-1

    Applicable For:                    A876 SNS, SA/LR Dual, A443 Dual, A876 SNS MHS

    When it is defined, the FIX shall be displayed at the end of the waypoints list.

     

    SNS-V2-HMI-933

    Applicable For:                    A876 SNS, SA/LR Dual, A443 Dual, A876 SNS MHS

    However, the waypoint coordinates shall be truncated to the minutes when displayed in the list.

    CD-PNI-SQT-SSA057-2

    Applicable For:                    A876 SNS, SA/LR Dual, A443 Dual

    When the switch is not active, then: print the context


    Sub InsertRowK()
    
        Dim ExcelApp As Object
        Dim oDoc As Object
        Dim oRng As Object, oEndRng As Object, otest As Object
        Dim NextRow As Long, NextRow1 As Long
        Dim tSheet As Worksheet
        On Error GoTo ReturnError
        Dim Val As String
        Set oDoc = ActiveDocument
        Set oRng = oDoc.Range
        Set otest = oDoc.Range
        
        Dim text As String
        Dim result As String
        Set ExcelApp = CreateObject("Excel.Application")
        Set wbExcel = ExcelApp.Workbooks.Add
        
            ExcelApp.Visible = True
            Set tSheet = ExcelApp.Sheets("Sheet1")
       
            
        
         'Find the next empty row of the worksheet
        NextRow = 2
        NextRow = tSheet.Cells(tSheet.Rows.Count, 1).End(-4162).Row + 1
        
        With oRng.Find
             'Find the text string
            Do While .Execute(FindText:="SNS-V2-HMI")            
                Do Until oRng.Words.Last = "Rationale"
                     'Move the end of the range one word at a time
                    oRng.MoveEnd 1, 1
                Loop
                
                otest.MoveEnd 2, -1
                otest.End = oRng.End - 1
                otest.MoveStartUntil Chr(1)
                otest.Start = oRng.Start
              
                tSheet.Cells(NextRow, 1).Value = otest.Words(1).text + otest.Words(2).text + otest.Words(3).text + otest.Words(4).text + otest.Words(5).text + otest.Words(6).text + otest.Words(7).text + otest.Words(8).text + otest.Words(9).text + otest.Words(10).text
                oRng.MoveEnd 2, -1
                oRng.End = oRng.End - 1
                oRng.MoveStartUntil Chr(9)
                oRng.Start = oRng.Start + 1
                tSheet.Cells(NextRow, 2) = oRng.text
               
                 'Format the cell
                With tSheet.Cells(NextRow, 1)
                    .ColumnWidth = "48"
                    .HorizontalAlignment = xlGeneral
                    .VerticalAlignment = xlTop
                    .WrapText = True
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
                End With
                 'Collapse the range to its end
                oRng.Collapse 0
                 'Increment the row
                NextRow = NextRow + 1
            Loop
            
                 ' read field values
        Dim ofld As Field
        Dim oPara As Range
        Dim A As Variant
        Set oPara = ActiveDocument.Paragraphs(1).Range
            oPara.End = oPara.End - 1
            oPara.MoveStartUntil Chr(9)
            oPara.Start = oPara.Start + 1
          irow = 2
          icol = 3
          
        For Each ofld In ActiveDocument.Fields
            If ofld.Type = wdFieldQuote Then
                Select Case True
                    Case InStr(1, ofld.Code, "Applicable For:")
                        tSheet.Cells(irow, icol).Value = GetValue(ofld)
               
                End Select
            End If
            
            If Not tSheet.Cells(irow, icol).Value = "" Then
                 icol = icol + 1
            End If
            
            If icol = 6 Then
                irow = irow + 1
                icol = 3
           End If
           
        Next ofld
    lbl_Exit:
        Set ofld = Nothing
        Set oPara = Nothing
        End With
        'Exit Function
        
    ReturnError:
    
        MsgBox "Extracted completly"
            Set ExcelApp = Nothing: Set oDoc = Nothing: Set wbExcel = Nothing
    End Sub
    
    Private Function GetValue(ofld As Field) As String
        Dim oPara As Range
        Set oPara = ofld.result.Paragraphs(1).Range
            oPara.End = oPara.End - 1
            oPara.Start = ofld.result.End + 1
            GetValue = oPara.text
    lbl_Exit:
    
        Exit Function
    End Function
    
    
    
    
    
    
    
    

    the contents to be extracted in excel is to be like this,

    please any one can help me out thanks in advance

    Chapter  title require Text A876 SNS  SA/LR Dual  A443 Dual A876 SNS MHS
    chapter 1  Subscribe CD-PNI-SQT-SSA056-1 When it is defined, the FIX shall be displayed at the end of the waypoints list. YES YES YES YES
    chapter 1  Subscribe SNS-V2-HMI-933 However, the waypoint coordinates shall be truncated to the minutes when displayed in the list. YES YES YES YES
    chapter 1  Subscribe CD-PNI-SQT-SSA057-2 When th switch is not active, then: print the context YES YES YES NO



    Saturday, June 20, 2015 4:36 PM

All replies

  • The code you posted appears based on a similar question that you asked at http://www.vbaexpress.com/forum/showthread.php?52788-Unable-to-extract-the-field-values-in-Word, but this requirement is different.

    Given what you have in the code, you will need to post a sample of the actual document that you are trying to process so we can see how it is formatted and also to see how the Chapter headings work in relation to the texts that follow.


    Graham Mayor - Word MVP
    www.gmayor.com

    Sunday, June 21, 2015 7:45 AM
  • Thanks for your reply it was similar one only. I have attached the word document on one drive

    https://onedrive.live.com/redir?resid=6FE4C49B1E6682E!1880&authkey=!AJ5nNM697LL1ZMI&ithint=file%2cdocx

    please do help me out. Thanks in advance

    Sunday, June 21, 2015 8:23 AM
  • If the document is formatted throught like the example then

    Sub ExtractDoc()
    Dim xlApp As Object
    Dim xlBook As Object
    Dim NextRow As Long
    Dim oPara As Paragraph
    Dim oRng As Range
    Dim oRngA As Range, oRngB As Range
    Dim strChapter As String
    Dim strTitle As String
    Dim vText As Variant
    Dim i As Long, j As Long
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
        Set xlBook = xlApp.Workbooks.Add
        xlApp.Visible = True
        xlBook.Sheets(1).Range("A1") = "Chapter"
        xlBook.Sheets(1).Range("B1") = "Title"
        xlBook.Sheets(1).Range("C1") = "Require"
        xlBook.Sheets(1).Range("D1") = "Text"
        xlBook.Sheets(1).Range("E1") = "A876 SNS"
    
    
        For i = 1 To ActiveDocument.Paragraphs.Count
            Set oRng = ActiveDocument.Paragraphs(i).Range
            oRng.End = oRng.End - 1
            If InStr(1, oRng.Text, "Chapter") > 0 Then
                vText = Split(oRng.Text, Chr(32))
                strChapter = vText(0) & Chr(32) & vText(1)
                strTitle = ""
                For j = 2 To UBound(vText)
                    strTitle = strTitle & Chr(32) & vText(j)
                Next j
                strTitle = Trim(strTitle)
            End If
            If InStr(1, oRng.Text, "Applicable For:") > 0 Then
                NextRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row + 1
                xlBook.Sheets(1).Cells(NextRow, 1) = strChapter
                xlBook.Sheets(1).Cells(NextRow, 2) = strTitle
                Set oRngA = ActiveDocument.Paragraphs(i - 1).Range
                oRngA.End = oRngA.End - 1
                xlBook.Sheets(1).Cells(NextRow, 3) = oRngA.Text
                Set oRngB = ActiveDocument.Paragraphs(i + 1).Range
                oRngB.End = oRngB.End - 1
                xlBook.Sheets(1).Cells(NextRow, 4) = oRngB.Text
                If InStr(1, oRng.Text, "A876 SNS") > 0 Then
                    xlBook.Sheets(1).Cells(NextRow, 5) = "YES"
                Else
                    xlBook.Sheets(1).Cells(NextRow, 5) = "NO"
                End If
            End If
        Next i
    End Sub
    


    Graham Mayor - Word MVP
    www.gmayor.com

    • Proposed as answer by ryguy72 Tuesday, June 23, 2015 9:16 PM
    Sunday, June 21, 2015 11:30 AM
  • Thanks very much for your reply Graham mayor! I tried with changing the chapter name with different name  sequentailly, it was mis functional. And in the third cell the paragraph is able to pull only one sentence, i tried to pull all text in the pararaph w.r.t t to the next requirement.

    I have tried the code

    For i = 1 To ActiveDocument.Paragraphs.Count
            Set oRng = ActiveDocument.Paragraphs(i).Range
            oRng.End = oRng.End - 1
            If InStr(1, oRng.Text, "") > 0 Then
                vText = Split(oRng.Text, Chr(32))
                strChapter = vText(0) & Chr(32) & vText(1)
                strTitle = ""
                For j = 2 To UBound(vText)
                    strTitle = strTitle & Chr(32) & vText(j)
                Next j
                strTitle = Trim(strTitle)
            End If

    I have attached a document for reference.

    https://onedrive.live.com/redir?resid=6FE4C49B1E6682E!1883&authkey=!AHluiuKG-mjRhzI&ithint=file%2cdocx

    Please help me out. Thanks in advance.


    Monday, June 22, 2015 8:46 AM
  • The document you have just posted bears no relationship to the previous document that you posted, so of course it won't work. I don't have the time to keep working out new code sequences when you keep moving the goalposts.

    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, June 22, 2015 11:17 AM
  • Hi sorry, for the inconvenience, please do help me out. i tried but unable get the results. Thanks. 
    Monday, June 22, 2015 11:44 AM
  • Hi graham mayor, i tried out but unable to get the results. please can you help me out. Sorry for the irrelevant docs.thanks in advance.
    Monday, June 22, 2015 6:50 PM
  • There are lots of ways to move data from Word to Excel.  Here's one option for you to consider.

    Sub GetWordDocContents()
      Dim oWord As Object
      Dim vFiles
      Dim iFile As Integer
      Dim r As Range
      Dim LastRow As Long
       
      vFiles = Application.GetOpenFilename("Word files (*.doc*),*.doc*", Title:="Please select the files you want to copy from", MultiSelect:=True)
      If TypeName(vFiles) = "Boolean" Then Exit Sub ' Cancelled
      Set oWord = CreateObject("Word.Application")
      oWord.Visible = True
      Set r = ActiveSheet.Range("A1")
      For iFile = LBound(vFiles) To UBound(vFiles)
        oWord.Documents.Open vFiles(iFile)
        oWord.ActiveDocument.Select
        oWord.Selection.Copy
        ActiveSheet.Paste r
       
        r.Offset(0, 6).Value = oWord.ActiveDocument.Name
        
        Set r = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
        oWord.ActiveDocument.Close False
    
      Next
      oWord.Quit
      Set oWord = Nothing
      ActiveSheet.Columns.AutoFit
    
        ' Delete row if blank
        Columns("A:A").Select
        For LastRow = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
           If Cells(LastRow, 1) = "" Then Rows(LastRow).Delete
        Next LastRow
        
    End Sub
    


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Tuesday, June 23, 2015 9:18 PM