Consulting

Results 1 to 2 of 2

Thread: Copying the tables and corresponding section header from a word using excel vba

  1. #1
    VBAX Newbie
    Joined
    Jun 2019
    Posts
    1
    Location

    Copying the tables and corresponding section header from a word using excel vba

    Hi,I am trying to copy the tables and corresponding the section number and heading from word documents to an excel sheet.
    I am able to copy the tables to the excel sheet. But the code is not finding the corresponding section and section header.
    It will be helpful if anyone have any idea!!!

    eg: My tables are always under the heading 3. So in the vba, i am trying to loop through the tables and search backward for the heading 3, which is not happening. below is my VBA code.

    Public Sub exportTables()
    Dim t
    Dim r
    Dim ID As String
    Dim prefix As String
    Dim xR As Integer
    Dim xROld As Integer
    Dim chapter As String
    Dim header As String
    Dim foundSomething As Boolean
    Dim firstCellText As String
    Dim secondCellText As String
    Dim Doc_path As String
    Dim docList As String
    Dim Workbook As Object
    Dim wordApp As Object
    Dim DocApp As Object
    MsgBox "Please close all the Microsoft Word Applications"
    Do
        On Error Resume Next
        Set wordApp = GetObject(, "Word.Application")
        If Not wordApp Is Nothing Then
            wordApp.Quit
            Set wordApp = Nothing
        End If
        Loop Until wordApp Is Nothing
        ' track Excel worksheet row number
        xR = 2
        Doc_path = "C:\Users\Mathew\Documents"
        ' get the list of all documents in the folder
        docList = Dir(Doc_path & "\*.doc", vbNormal)
        ThisWorkbook.Sheets("Word Data").Activate
        ' Loop through all Word documents in the folder to get texts in the tables
        While docList <> ""
            ' Create a Word object.
            Set wordApp = CreateObject("Word.Application")
            wordApp.Visible = False      ' Do not show the file.
            ' Create a DocApp object and open the Word file.
            Set DocApp = wordApp.Documents.Open(Filename:=Doc_path & "\" & docList, AddToRecentFiles:=False, Visible:=False)
            With wordApp.ActiveDocument
                ' Loop through all tables in active Word document
                For Each t In DocApp.Tables
                    On Error Resume Next
                    t.Range.Select
                    ' Setup search to find header and corresponding section number
                    t.Range.Selection.Find.ClearFormatting
                    t.Range.Selection.Find.Style = "Heading 3"
                    With t.Range.Selection.Find
                        .Text = ""
                        .Replacement.Text = ""
                        .Forward = False
                        .Wrap = wdFindContinue
                        .Format = True
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                    End With
                    foundSomething = t.Range.Selection.Find.Execute
                    If foundSomething = True Then
                        'Determine the string to be used for header(by trimming page break if any)
                        If InStr(t.Range.Selection.Selection.Text, Chr(12)) = 1 Then
                            header = Mid(t.Range.Selection.Text, 2, Len(t.Range.Selection.Text) - 2)
                            Else
                            header = Mid(t.Range.Selection.Text, 1, Len(t.Range.Selection.Text) - 1)
                        End If
                        ' Determine the string for chapter
                        chapter = "Chapter " & t.Range.Selection.ListFormat.ListString
                    End If
                    ' xR tracks the current row in the Excel worksheet
                    xROld = xR
                    ' Loop through rows in current table
                    For Each r In t.Rows
                        ' First cell's text
                       firstCellText = r.Cells(1).Range.Text
                       ' Check if row is not empty
                      If Not (r Is Nothing) Then
                         ' Get text from second cell of current row
                         secondCellText = r.Cells(2).Range.Text
                         ' First column contains serial number
                        ThisWorkbook.ActiveSheet.Cells(xR, 1) = xR - 1
                        ' Second column contains the document section no.
                        ThisWorkbook.ActiveSheet.Cells(xR, 3) = chapter
                        ' Third column contains the header name
                        ThisWorkbook.ActiveSheet.Cells(xR, 4) = header
                        ' fourth column contains the firstCellText
                       ThisWorkbook.ActiveSheet.Cells(xR, 5) = firstCellText
                       ' fifth column contains the secondCellText
                       ThisWorkbook.ActiveSheet.Cells(xR, 6) = Left(secondCellText, Len(secondCellText) - 2)
                       ' Increment to next row in Excel worksheet
                       xR = xR + 1
                    End If
                Next r
            Next t
        End With
        ' Clean up.
        DocApp.Close
        wordApp.Quit
        Set wordApp = Nothing
        Set DocApp = Nothing
        docList = Dir()
    Wend
    ThisWorkbook.ActiveSheet.Cells.EntireColumn.AutoFit
    End Sub
    Last edited by Aussiebear; 04-16-2023 at 10:59 PM. Reason: Adjusted the code tags

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Since you're opening the document in a hidden state, there is no active document. There is also no need to kill any existing Word sessions. Your code could do with major improvements in other areas, too. Try something along the lines of (untested). Run with Word visible for testing, though.
    Public Sub ImportWordTables()
    Dim xR As Long
    Dim xROld As Long
    Dim r As Long
    Dim ID As String
    Dim prefix As String
    Dim chapter As String
    Dim header As String
    Dim firstCellText As String
    Dim secondCellText As String
    Dim Doc_path As String
    Dim docList As String
    Dim xlSht As Worksheet
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdRng As Object
    Dim wdTbl As Object
    ' track Excel worksheet row number
    xR = 2
    Set xlSht = ThisWorkbook.Sheets("Word Data")
    Doc_path = "C:\Users\Mathew\Documents"
    ' get the list of all documents in the folder
    docList = Dir(Doc_path & "\*.doc", vbNormal)
    ' Create a Word object.
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False      ' Do not show Word.
    ' Loop through all Word documents in the folder to get texts in the tables
    Do While docList <> ""
        Set wdDoc = wdApp.Documents.Open(Filename:=Doc_path & "\" & docList, AddToRecentFiles:=False)
        With wdDoc
            With .Range
                With .Find
                    .ClearFormatting
                    .Text = ""
                    .Replacement.Text = ""
                    .Forward = False
                    .Wrap = wdFindStop
                    .Format = True
                    .Style = "Heading 3"
                    .MatchCase = False
                    .MatchWholeWord = False
                   .MatchWildcards = False
                   .MatchSoundsLike = False
                   .MatchAllWordForms = False
                   .Execute
                End With
                If .Find.Found = True Then
                    Set wdRng = .Duplicate.GoTo(What:=-1, Name:="\HeadingLevel") ' -1 = wdGoToBookmark
                    header = Split(wdRng.Paragraphs.First.Range.Text, vbCr)(0)
                    chapter = "Chapter " & wdRng.Paragraphs.First.Range.ListFormat.ListString
                    ' Loop through all tables in active Word document
                    For Each wdTbl In wdRng.Tables
                        ' xR tracks the current row in the Excel worksheet
                        xROld = xR
                       With wdTbl
                           ' Loop through rows in current table
                           For r = 1 To .Rows.Count
                               ' First cell's text
                               firstCellText = Split(.Cell(r, 1).Range.Text, vbCr)(0)
                               ' Get text from second cell of current row
                               secondCellText = Split(.Cell(r, 2).Range.Text, vbCr)(0)
                               ' First column contains serial number
                               xlSht.Cells(xR, 1) = xR - 1
                                ' Second column contains the document section no.
                                xlSht.Cells(xR, 3) = chapter
                                ' Third column contains the header name
                                xlSht.Cells(xR, 4) = header
                                ' fourth column contains the firstCellText
                                xlSht.Cells(xR, 5) = firstCellText
                                ' fifth column contains the secondCellText
                                xlSht.Cells(xR, 6) = secondCellText
                                ' Increment to next row in Excel worksheet
                                xR = xR + 1
                            Next
                        End With
                    End If
                End If
            End With
            .Close False
        End With
        docList = Dir()
    Loop
    ' Clean up.
    wdApp.Quit
    Set wdTbl = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
    ThisWorkbook.ActiveSheet.Cells.EntireColumn.AutoFit
    End Sub
    Last edited by Aussiebear; 04-16-2023 at 11:10 PM. Reason: Adjusted the code tags
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •