Hi All
I need some help modifying code that I found here and is shown below, which copies entries from tables in Word into Excel. The modifications I would like to make are to loop through all word documents in the current folder rather than prompting for a file name, with the data from each Word document appearing as a new Sheet.
The alternative is to have each Word document represented by a row in a sheet, with all data from the tables in that document in separate columns.
Thanks in advance!
I need some help modifying code that I found here and is shown below, which copies entries from tables in Word into Excel. The modifications I would like to make are to loop through all word documents in the current folder rather than prompting for a file name, with the data from each Word document appearing as a new Sheet.
The alternative is to have each Word document represented by a row in a sheet, with all data from the tables in that document in separate columns.
Thanks in advance!
Code:
Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer
Dim i As Long
Dim r As Long
Dim c As Long
Dim lastrow As Long
On Error Resume Next
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
ActiveSheet.Range("A:AZ").ClearContents
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
tableNo = wdDoc.tables.Count
For i = 1 To tableNo
With .tables(i)
'copy cell contents from Word table cells to Excel cells
For iRow = lastrow To .Rows.Count
For iCol = 1 To .Columns.Count
On Error Resume Next
Worksheets("Data").Cells(r, c) = Trim(WorksheetFunction.Clean(Replace(Replace(.cell(iRow, iCol).Range.Text, Chr(13), " "), Chr(10), "")))
c = c + 1
Next iCol
c = 1
r = r + 1
Next iRow
End With
c = 1
Next i
End With
End Sub
Attachments
Last edited by a moderator: