Get all data from word table into excel

[blanchard306]

I'm trying to get this code to extract all the table data from the word files in the folder location and put them into the same excel sheet. The part of the code in blue (or sh1.Cells(x,2)) is where i'm having trouble changing it to capture all table data not just one row of data from the word file. Thanks for any help you can give i'm a bit new to all this.


Sub extractwordtables()

Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer

FolderName = "C:\code" ' Change this to the folder containing your word documents

Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files

x = 1
For Each wd In objFiles
If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
sh1.Cells(x, 1) = wd.Name
sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)

x = x + 1
wrdDoc.Close
End If

Next wd
wordApp.Quit
End Sub

[SamT]

Using an Integer for a row assignment can fail.

[snb]

sub M_snb()
sn=filter(split(createobject("wscript.shell").exec("cmd /c Dir G:\Of\*.docx /b").stdout.readall,vbcrlf),"~",false)

for each it in sn
With GetObject("G:\OF\" & it )
.tables(1).Range.Copy
Sheet1.Paste Sheet1.Cells(rows.count,1).end(xlup).offset(2)
.close 0
End With
next
End Sub