Macro to copy table from Word into Excel based on table headers

[Lexcel18]

Hello, I would like to create a macro that when copies a table (with a specific heafer) from a Word file into an Excel worksheet.
The top row (header) of the table I need is always the same in all files and I think this will be a good way to to identify the table. An alternative option would be to copy the last table from the word file. I found some related info here which I am planning to "play" with to create this macro: https://www.mrexcel.com/forum/excel-questions/36875-word-table-into-excel-worksheet.html .

 

[Macropod]

For what you've described you could use code like:

Sub GetWordTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String, i As Long
Dim WkBk As Workbook, WkSht As Worksheet
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkBk = ThisWorkbook
With wdApp
  'Hide the Word session
  .Visible = False
  'Disable Alerts
  .DisplayAlerts = wdAlertsNone
  'Disable Auto Macros in the documents being processed
  .WordBasic.DisableAutoMacros
  'Loop through all documents in the folder
  strFile = Dir(strFolder & "\*.doc", vbNormal)
  While strFile <> ""
    'Open the document
    Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, _
      ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      If .Tables.Count > 0 Then
        'Create an output sheet for the document
        Set WkSht = WkBk.Sheets.Add
        WkSht.Name = Split(strFile, ".doc")(0)
        'Process the last table in the document
        With .Tables(.Tables.Count).Range
          For i = 1 To .Cells.Count
            With .Cells(i)
              WkSht.Cells(.RowIndex, .ColumnIndex) = Split(.Range.Text, vbCr)(0)
            End With
          Next
        End With
      End If
    .Close SaveChanges:=False
    End With
    strFile = Dir()
  Wend
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

The above code extracts data from the last table in each Word document in the selected folder. Do note that there is a limitation in writing Word table data to Excel, in that separate paragraphs in a Word cell would be written to separate Excel cells; the above code simply extracts the first paragraph from each cell.

 

[Lexcel18]

Thank you. I will try out the code in a few days when I will have access to a PC. (I'm posting from my smartphone.) As far as I remember there is only one paragraph in each cell of the tables I need, so the code should fit my needs pretty nicely.

 

[Lexcel18]

Thanks, it works like a charm.

 

[ExcelGoose]

This is a great Macro. Does anyone know how to modify it so that the tables are posted into one tab rather than creating new tabs for each file?