Extract table data from multiple Word documents to one Excel sheet

Hello,

I am trying to extract table data from multiple Word documents to one Excel sheet. I found a couple of already written VBA scripts for this but there is something more specific I am looking for. In addition to extracting data, I would like the every other cell to extracted as headers. However, because there are multiple word documents, this would require each of the cell values to be matched with the original row header before placing the data into its appropriate row. If something is mis-spelled or is another name, it should create a new header. I have attached a picture to clarify a bit.

Attachment 21266

Oh and there are also multiple tables in each word document 0.0

I don't know if this is too complicated of a task but that is what would be ideal. Below is the script that I found online that gives me the table data but all in one row per word document:

Code:

---

Option Explicit
 
Sub test()
 
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oCell As Word.Cell
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long
 
Application.ScreenUpdating = False
 
Set oWord = CreateObject("Word.Application")
 
sPath = "C:\Documents\H\" 'change the path accordingly
 
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
 
sFile = Dir(sPath & "*.doc")
 
r = 2 'starting row
c = 1 'starting column
Cnt = 0
Do While Len(sFile) > 0
    Cnt = Cnt + 1
    Set oDoc = oWord.Documents.Open(sPath & sFile)
    For Each oCell In oDoc.Tables(1).Range.Cells
        Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
        c = c + 1
    Next oCell
    oDoc.Close SaveChanges:=False
    r = r + 1
    c = 1
    sFile = Dir
Loop
 
Application.ScreenUpdating = True
 
If Cnt = 0 Then
    MsgBox "No Word documents were found...", vbExclamation
End If
 
End Sub

---

You could use an Excel macro like:

Code:

---

Sub GetTableData()
'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, Tbl As Word.Table
Dim strFolder As String, strFile As String, WkSht As Worksheet, r As Long
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet: r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    For Each Tbl In .Tables
      With Tbl
        If Split(.Cell(1, 1).Range.Text, vbCr)(0) = "Name:" Then
          r = r + 1
          WkSht.Cells(r, 1) = Split(.Cell(1, 2).Range.Text, vbCr)(0)
          WkSht.Cells(r, 2) = Split(.Cell(1, 4).Range.Text, vbCr)(0)
          WkSht.Cells(r, 3) = Split(.Cell(1, 6).Range.Text, vbCr)(0)
          WkSht.Cells(r, 4) = Split(.Cell(2, 2).Range.Text, vbCr)(0)
          WkSht.Cells(r, 5) = Split(.Cell(2, 4).Range.Text, vbCr)(0)
          WkSht.Cells(r, 6) = Split(.Cell(5, 2).Range.Text, vbCr)(0)
          WkSht.Cells(r, 7) = Split(.Cell(6, 2).Range.Text, vbCr)(0)
          WkSht.Cells(r, 8) = Split(.Cell(7, 2).Range.Text, vbCr)(0)
        End If
      End With
    Next
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = 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

---

Note: I've had to guess what your document table cell references are, as that's not clear from your screenshot.