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

[tmathew]

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