extract data from multiple tables from multiple word docs into Excel

Hi,

I am trying to find code that would let me extract data from multiple tables from multiple word docs into Excel.

I currently have the code below but it only allows me to extract data from one table. I would like to extract data from all the tables, so all the data from one word doc would be within one excel row.

I have looked up code and tried to figure it out by myself but to no avail.


please help and thanks in advance!



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

From your description, it appears that you need to add a second loop to loop through the tables. Maybe something like

Code:

---

Option Explicit

Sub test()

Dim oWord As Object
Dim oDoc As Object
Dim oTable As Object
Dim oCell As Object
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long

    Application.ScreenUpdating = False
    On Error Resume Next
    Set oWord = GetObject(, "Word.Application")
    If Err Then
        Set oWord = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    sPath = "C:\Documents\"    '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)
        If oDoc.tables.Count > 0 Then
            For Each oTable In oDoc.tables
                For Each oCell In oTable.Range.Cells
                    Cells(r, c).value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
                    c = c + 1
                Next oCell
            Next oTable
            r = r + 1
            c = 1
        End If
        oDoc.Close SaveChanges:=False
        sFile = Dir
        DoEvents
    Loop
    Application.ScreenUpdating = True
    If Cnt = 0 Then
        MsgBox "No Word documents were found...", vbExclamation
    End If
End Sub

---

I take it we can assume the cell processing is what you require?

Yes it works now! thanks very much! Yes I was interested in the cell data only.