extract data from multiple tables from multiple word docs into Excel

[Kijoon]

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

[gmayor]

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


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?

[Kijoon]

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