VBA to Extract Specific table data from multiple words to one excel worksheet

Hi Team,

I have the below request: Extract specified tables from multiple words to one excel worksheet

1. Open multiple word files one after other
2. Copy tables from the word files with a pre defined column headers (not all tables). There are several such tables in a single word file itself that needs to be copied.
3. Create a "Master" Worksheet and paste the tables. Include the file name as a starting column for recognizing the data from which file is copied.
4. Close the opened word files without saving and move to the next word file in the folder.

Thank you so much
Shan

Any response on this request please?

Here is my working vba. Additionally I want the Heading & Sub Heading details to be added next to the table where the table was present in the word file. Attaching the word file for reference and trial. /Option Explicit

Sub ImportWordTableWithSpecificHeaderAndFormat()
    Dim WS As Worksheet
    Dim A As Long, B As Long
    Dim I As Long, J As Long
    Dim xlCol As Long
    Dim NextRow As Long
    Dim StartRow As Long ' To remember where the data starts
    Dim FN As Variant
    Dim CellData As Variant ' String
    Dim WordPath As String
    Dim wrdApp As Object
    Dim wrdDoc As Object
    Dim TableRow As Object
    Dim HeaderCheck As Boolean
    Dim masterSheet As Worksheet
    Dim sheetExists As Boolean


On Error Resume Next

' Get existing instance of Word if it exists.
Set wrdApp = GetObject(, "Word.Application")
If Err <> 0 Then
    ' If GetObject fails, then use CreateObject instead.
    Set wrdApp = CreateObject("word.application")
End If
On Error GoTo 0

FN = Application.GetOpenFilename("Word Files (*.doc?), *.doc?", _
    , "Navigate to folder containing Word Files", , True)
If Not IsArray(FN) Then GoTo TheEnd

' Check if "Master" worksheet exists
    sheetExists = False
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name = "Master" Then
            sheetExists = True
            Set masterSheet = WS
            Exit For
        End If
    Next WS

    If sheetExists Then
        ' Clear data in the existing "Master" worksheet
        masterSheet.Cells.Clear
    Else
        ' Create a new "Master" worksheet
        Set masterSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        masterSheet.Name = "Master"
    End If

    ' Create a 5x5 table starting from cell A1
    With masterSheet

'Set WS = Worksheets(1)
'With WS
    StartRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    NextRow = StartRow
 '   .Cells(StartRow - 1, 3).Value = "File Imported from" ' Add the column header
    For J = 1 To UBound(FN)
        If Not wrdApp Is Nothing Then
            Set wrdDoc = wrdApp.Documents.Open(FN(J))
            For I = 1 To wrdDoc.Tables.Count
                ' Check if the first cell in the first row matches "Test Case Name"
                HeaderCheck = (Trim(wrdDoc.Tables(I).Cell(1, 1).Range.Text) Like "Test Step*")
                If HeaderCheck Then
                    For Each TableRow In wrdDoc.Tables(I).Rows
                        NextRow = NextRow + 1
                        xlCol = 1 ' Start from the second column for data to leave the first column for filenames
                        For Each CellData In TableRow.Range.Cells
                            WS.Cells(NextRow, xlCol + 1) = Left(CellData.Range.Text, Len(CellData.Range.Text) - 2)
                            xlCol = xlCol + 1
                        Next CellData
                        masterSheet.Cells(NextRow, 1) = FN(J) ' Add filename to the first column
                    Next TableRow
                End If
            Next I
            wrdDoc.Close False
        End If
    Next J

' Formatting
Range("A3:F3").Select
        Selection.Style = "Accent1"
        Selection.Font.Bold = True
        Selection.Font.Name = "Calibri"
        Selection.Font.Size = 14
'        Selection.Borders.LineStyle = xlContinuous
'        Selection.WrapText = True
'        Selection.EntireColumn.AutoFit
 
   ' Align other columns
    With WS.Columns("A:F")
        .VerticalAlignment = xlTop
        .HorizontalAlignment = xlLeft
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Borders.LineStyle = xlContinuous
        .WrapText = True
        .EntireColumn.AutoFit
    End With
ActiveWindow.DisplayGridlines = False
    ' Set specific column widths
    WS.Columns("A:A").ColumnWidth = 50
     WS.Columns("B:B").ColumnWidth = 15
    WS.Columns("C:C").ColumnWidth = 35
    WS.Columns("D:D").ColumnWidth = 67
    WS.Columns("E:E").ColumnWidth = 35
    WS.Columns("F:F").ColumnWidth = 12

    ' Center align column B
    With WS.Columns("B:B")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    ' Align row 3
    With WS.Rows("3:3")
        .VerticalAlignment = xlCenter
    End With
   
End With
  ' Move the pointer to cell A1
    WS.Range("A1").Select
TheEnd:
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
End Sub