VBA - Import multiple tables from Word

S

Skovgaard

Board Regular
Joined
Oct 18, 2013
Messages
204
Office Version
  1. 365
Platform
  1. Windows
Hello Experts,

I need your help, to modify below VBA code, which I've found exploring the web.

I have several word documents in a folder, containing different number of tables.
Below I've pasted a picture of the word document and the result in Excel.

As you may see in the result, the top of the document, is all pasted into cell A4, and the rest in each cell.
If I do a normal copy/paste of the "top-table", it will paste it into each cell in Excel.

What I would like to achieve is, that all below yellow marked cells, should be copied into each cell in Excel, and on the same row.
Anyone who can help, modifying the code to do so?


Sample Word Doc:
1653290219827.png


Result from Macro:
1653290265103.png



VBA Code: 
Sub Main()
Dim FSO As Object:  Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "L:\Finance\Ad hoc\USH\Diverse\Materiale Certifikater\Certifikater\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim LR As Long: LR = 4
Dim fil As Object

ActiveSheet.Range("A4:AZ10000").ClearContents

For Each fil In fold.Files
    ImportWordTable fil.path, LR
Next fil

End Sub

Sub ImportWordTable(docPath As String, ByRef resultRow As Long)

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 tableStart As Integer
Dim tableTot As Integer

On Error Resume Next

Set wdDoc = GetObject(docPath) 'open Word file

With wdDoc
    tableNo = wdDoc.tables.Count
    tableTot = wdDoc.tables.Count
    If tableNo = 0 Then
        MsgBox "This document contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If

    For tableStart = 1 To tableTot
        With .tables(tableStart)
            'copy cell contents from Word table cells to Excel cells
            For iRow = 1 To 5 '.Rows.Count
                For iCol = 1 To .Columns.Count
                    Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                Next iCol
                resultRow = resultRow + 1
            Next iRow
        End With
        resultRow = resultRow + 1
    Next tableStart
End With

End Sub

/Skovgaard
 
Sort by date Sort by votes
NdNoviceHlp said:
Skovgaard this seems like it should work. You will still need the main sub and top of code module declarations. Also, I set this up for sheet 1 rather than the active sheet so you may need to change to suit. Dave
Code: 
Sub ImportWordTable(docPath As String, resultRow As Long)
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 tableStart As Integer
Dim tableTot As Integer
Dim SplitTemp As Variant, Cnt As Integer, ColCnt As Integer
Dim RowCnt As Integer
'On Error Resume Next

WrdObj.Documents.Open Filename:=docPath
WrdObj.Visible = False

With WrdObj.Activedocument
    tableNo = .tables.Count
    tableTot = .tables.Count
    If tableNo = 0 Then
        MsgBox "This document " & docPath & " contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If

ColCnt = 1
For tableStart = 1 To tableTot
With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = LBound(SplitTemp) To UBound(SplitTemp)
If (Cnt >= 22 And Cnt <= 30) Or (Cnt >= 42 And Cnt <= 50) Or (Cnt >= 62 And Cnt <= 68) Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = SplitTemp(Cnt)
ColCnt = ColCnt + 1
End If
Next Cnt
           
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
If iCol = 2 Or iCol = 4 Or iCol = 6 Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
ColCnt = ColCnt + 1
End If
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
LR = resultRow
End Sub
Click to expand...

Hi Dave,

Really appreciate you're helping.
When I ran the code, all the minerals from "table1" is loaded on the same row in Excel, and then I get below error message:
So the cells from "table2" is missing.

1654147730304.png


When pressing debug, it highlights this line - Any idea what this is?

1654147774647.png


/Skovgaard
 
Upvote 0

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
There are apparently 2 tables. So trial this...
Code: 
Sub ImportWordTable(docPath As String, resultRow As Long)
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 tableStart As Integer
Dim tableTot As Integer
Dim SplitTemp As Variant, Cnt As Integer, ColCnt As Integer
Dim RowCnt As Integer
'On Error Resume Next

WrdObj.Documents.Open Filename:=docPath
WrdObj.Visible = False

With WrdObj.Activedocument
    tableNo = .tables.Count
    tableTot = .tables.Count
    If tableNo = 0 Then
        MsgBox "This document " & docPath & " contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If

ColCnt = 1
For tableStart = 1 To tableTot
With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = LBound(SplitTemp) To UBound(SplitTemp)
If (Cnt >= 22 And Cnt <= 30) Or (Cnt >= 42 And Cnt <= 50) Or (Cnt >= 62 And Cnt <= 68) Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = SplitTemp(Cnt)
ColCnt = ColCnt + 1
End If
Next Cnt
End With
'copy cell contents from Word table cells to Excel cells
With .tables(tableStart + 1)
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
If iCol = 2 Or iCol = 4 Or iCol = 6 Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
ColCnt = ColCnt + 1
End If
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
LR = resultRow
End Sub
Dave
 
Upvote 0
NdNoviceHlp said:
There are apparently 2 tables. So trial this...
Code: 
Sub ImportWordTable(docPath As String, resultRow As Long)
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 tableStart As Integer
Dim tableTot As Integer
Dim SplitTemp As Variant, Cnt As Integer, ColCnt As Integer
Dim RowCnt As Integer
'On Error Resume Next

WrdObj.Documents.Open Filename:=docPath
WrdObj.Visible = False

With WrdObj.Activedocument
    tableNo = .tables.Count
    tableTot = .tables.Count
    If tableNo = 0 Then
        MsgBox "This document " & docPath & " contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If

ColCnt = 1
For tableStart = 1 To tableTot
With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = LBound(SplitTemp) To UBound(SplitTemp)
If (Cnt >= 22 And Cnt <= 30) Or (Cnt >= 42 And Cnt <= 50) Or (Cnt >= 62 And Cnt <= 68) Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = SplitTemp(Cnt)
ColCnt = ColCnt + 1
End If
Next Cnt
End With
'copy cell contents from Word table cells to Excel cells
With .tables(tableStart + 1)
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
If iCol = 2 Or iCol = 4 Or iCol = 6 Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
ColCnt = ColCnt + 1
End If
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
LR = resultRow
End Sub
Dave
Click to expand...

Hi Dave,
Sorry, another error:
Would it help if I sent/uploaded the word document somewhere, in order for you not to spend so much time on this matter?
I wish you a nice weekend!

1654235549657.png


1654235559781.png



Seems like the mineral figures, are copied with a space before the number, can we exclude that?
1654235611023.png


/Skovgaard
 
Upvote 0
Skovgaard said:
Hi Dave,
Sorry, another error:
Would it help if I sent/uploaded the word document somewhere, in order for you not to spend so much time on this matter?
I wish you a nice weekend!

View attachment 66205

View attachment 66206


Seems like the mineral figures, are copied with a space before the number, can we exclude that?
View attachment 66207

/Skovgaard
Click to expand...
In case you need the Word doc, it can be downloaded on below link.

https://wetransfer.com/downloads/4066f5644d8eb76c8430ba2af55b145920220603105032/6ce0d7d33f1c9016dc6543b34b03e36620220603105057/839a59

/Skovgaard
 
Upvote 0
Well that certainly made it easier. There is only 1 table. This seems to work. Dave
Code: 
Dim WrdObj As Object

Sub Main()
Dim FSO As Object:  Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "L:\Finance\Ad hoc\USH\Diverse\Materiale Certifikater\Certifikater\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim fil As Object, LR As Long
LR = 4
Sheets("sheet1").Range("A4:AZ10000").ClearContents
'open Word application
On Error Resume Next
Set WrdObj = GetObject(, "word.application")
If Err.Number <> 0 Then
Set WrdObj = CreateObject("Word.Application")
End If
On Error GoTo ErFix
For Each fil In fold.Files
If InStr(fil.Name, "doc") Then
    ImportWordTable fil.path, LR
LR = LR + 1
End If
Next fil

ErFix:
WrdObj.Quit
Set WrdObj = Nothing
Set fold = Nothing
Set FSO = Nothing
End Sub

Sub ImportWordTable(docPath As String, resultRow As Long)
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 tableStart As Integer
Dim tableTot As Integer
Dim SplitTemp As Variant, Cnt As Integer, ColCnt As Integer
Dim RowCnt As Integer
'On Error Resume Next

WrdObj.Documents.Open Filename:=docPath
WrdObj.Visible = False
With WrdObj.Activedocument
    tableNo = .tables.Count
    tableTot = .tables.Count
    If tableNo = 0 Then
        MsgBox "This document " & docPath & " contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If
ColCnt = 1
'For tableStart = 1 To tableTot
'With .tables(tableStart)
With .tables(1)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = LBound(SplitTemp) To UBound(SplitTemp)
If (Cnt >= 22 And Cnt <= 30) Or (Cnt >= 42 And Cnt <= 50) Or (Cnt >= 62 And Cnt <= 68) Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(SplitTemp(Cnt))
ColCnt = ColCnt + 1
End If
Next Cnt

For iRow = 2 To 5
For iCol = 1 To .Columns.Count
If iCol = 2 Or iCol = 4 Or iCol = 6 Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
ColCnt = ColCnt + 1
End If
Next iCol
Next iRow
End With
'Next tableStart
End With

WrdObj.Activedocument.Close savechanges:=False
End Sub
 
Upvote 0
NdNoviceHlp said:
Well that certainly made it easier. There is only 1 table. This seems to work. Dave
Code: 
Dim WrdObj As Object

Sub Main()
Dim FSO As Object:  Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "L:\Finance\Ad hoc\USH\Diverse\Materiale Certifikater\Certifikater\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim fil As Object, LR As Long
LR = 4
Sheets("sheet1").Range("A4:AZ10000").ClearContents
'open Word application
On Error Resume Next
Set WrdObj = GetObject(, "word.application")
If Err.Number <> 0 Then
Set WrdObj = CreateObject("Word.Application")
End If
On Error GoTo ErFix
For Each fil In fold.Files
If InStr(fil.Name, "doc") Then
    ImportWordTable fil.path, LR
LR = LR + 1
End If
Next fil

ErFix:
WrdObj.Quit
Set WrdObj = Nothing
Set fold = Nothing
Set FSO = Nothing
End Sub

Sub ImportWordTable(docPath As String, resultRow As Long)
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 tableStart As Integer
Dim tableTot As Integer
Dim SplitTemp As Variant, Cnt As Integer, ColCnt As Integer
Dim RowCnt As Integer
'On Error Resume Next

WrdObj.Documents.Open Filename:=docPath
WrdObj.Visible = False
With WrdObj.Activedocument
    tableNo = .tables.Count
    tableTot = .tables.Count
    If tableNo = 0 Then
        MsgBox "This document " & docPath & " contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If
ColCnt = 1
'For tableStart = 1 To tableTot
'With .tables(tableStart)
With .tables(1)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = LBound(SplitTemp) To UBound(SplitTemp)
If (Cnt >= 22 And Cnt <= 30) Or (Cnt >= 42 And Cnt <= 50) Or (Cnt >= 62 And Cnt <= 68) Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(SplitTemp(Cnt))
ColCnt = ColCnt + 1
End If
Next Cnt

For iRow = 2 To 5
For iCol = 1 To .Columns.Count
If iCol = 2 Or iCol = 4 Or iCol = 6 Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
ColCnt = ColCnt + 1
End If
Next iCol
Next iRow
End With
'Next tableStart
End With

WrdObj.Activedocument.Close savechanges:=False
End Sub
Click to expand...

It has been a long process, hence bad explanations from me, and of course I should have uploaded a sample file earlier.
The only thing missing now, is that the number of tables in the word documents, can vary. Sometimes there's only one, other times there can be more.
In below link, I have uploaded a sample, with more tables in. Is it easy to adjust the VBA to include all tables, no matter if there is one or ten?

Once again thanks a lot, you're an Expert!

https://wetransfer.com/downloads/579fccd4cf085b42fbc8c1731372776920220605064753/036032d67a379763ce1ef5c5cacd66bb20220605064808/66d810

/Skovgaard
 
Upvote 0
Hi Skovgaard. Thanks for the example file. This re-worked code seems to trial OK. Dave
Code: 
Dim WrdObj As Object, LR As Long

Sub Main()
Dim FSO As Object:  Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "L:\Finance\Ad hoc\USH\Diverse\Materiale Certifikater\Certifikater\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim fil As Object
LR = 4
Sheets("sheet1").Range("A4:AZ10000").ClearContents
'open Word application
On Error Resume Next
Set WrdObj = GetObject(, "word.application")
If Err.Number <> 0 Then
Set WrdObj = CreateObject("Word.Application")
End If
On Error GoTo ErFix
For Each fil In fold.Files
If InStr(fil.Name, "doc") Then
    ImportWordTable fil.path, LR
LR = LR + 1
End If
Next fil

ErFix:
WrdObj.Quit
Set WrdObj = Nothing
Set fold = Nothing
Set FSO = Nothing
End Sub

Sub ImportWordTable(docPath As String, resultRow As Long)
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 tableStart As Integer
Dim tableTot As Integer
Dim SplitTemp As Variant, Cnt As Integer, ColCnt As Integer
Dim RowCnt As Integer
'On Error Resume Next

WrdObj.Documents.Open Filename:=docPath
WrdObj.Visible = False
With WrdObj.Activedocument
    tableNo = .tables.Count
    tableTot = .tables.Count
    If tableNo = 0 Then
        MsgBox "This document " & docPath & " contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If
For tableStart = 1 To tableTot
ColCnt = 1
With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = LBound(SplitTemp) To UBound(SplitTemp)
If (Cnt >= 22 And Cnt <= 30) Or (Cnt >= 42 And Cnt <= 50) Or (Cnt >= 62 And Cnt <= 68) Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(SplitTemp(Cnt))
ColCnt = ColCnt + 1
End If
Next Cnt

For iRow = 2 To 5
For iCol = 1 To .Columns.Count
If iCol = 2 Or iCol = 4 Or iCol = 6 Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
ColCnt = ColCnt + 1
End If
Next iCol
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
LR = resultRow - 1
WrdObj.Activedocument.Close savechanges:=False
End Sub
 
Upvote 0
Solution
NdNoviceHlp said:
Hi Skovgaard. Thanks for the example file. This re-worked code seems to trial OK. Dave
Code: 
Dim WrdObj As Object, LR As Long

Sub Main()
Dim FSO As Object:  Set FSO = CreateObject("Scripting.FileSystemObject")
Dim path As String: path = "L:\Finance\Ad hoc\USH\Diverse\Materiale Certifikater\Certifikater\"
Dim fold As Object: Set fold = FSO.getfolder(path)
Dim fil As Object
LR = 4
Sheets("sheet1").Range("A4:AZ10000").ClearContents
'open Word application
On Error Resume Next
Set WrdObj = GetObject(, "word.application")
If Err.Number <> 0 Then
Set WrdObj = CreateObject("Word.Application")
End If
On Error GoTo ErFix
For Each fil In fold.Files
If InStr(fil.Name, "doc") Then
    ImportWordTable fil.path, LR
LR = LR + 1
End If
Next fil

ErFix:
WrdObj.Quit
Set WrdObj = Nothing
Set fold = Nothing
Set FSO = Nothing
End Sub

Sub ImportWordTable(docPath As String, resultRow As Long)
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 tableStart As Integer
Dim tableTot As Integer
Dim SplitTemp As Variant, Cnt As Integer, ColCnt As Integer
Dim RowCnt As Integer
'On Error Resume Next

WrdObj.Documents.Open Filename:=docPath
WrdObj.Visible = False
With WrdObj.Activedocument
    tableNo = .tables.Count
    tableTot = .tables.Count
    If tableNo = 0 Then
        MsgBox "This document " & docPath & " contains no tables", _
        vbExclamation, "Import Word Table"
    ElseIf tableNo > 1 Then
        tableNo = tableTot
    End If
For tableStart = 1 To tableTot
ColCnt = 1
With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = LBound(SplitTemp) To UBound(SplitTemp)
If (Cnt >= 22 And Cnt <= 30) Or (Cnt >= 42 And Cnt <= 50) Or (Cnt >= 62 And Cnt <= 68) Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(SplitTemp(Cnt))
ColCnt = ColCnt + 1
End If
Next Cnt

For iRow = 2 To 5
For iCol = 1 To .Columns.Count
If iCol = 2 Or iCol = 4 Or iCol = 6 Then
Sheets("Sheet1").Cells(resultRow, ColCnt) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
ColCnt = ColCnt + 1
End If
Next iCol
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
LR = resultRow - 1
WrdObj.Activedocument.Close savechanges:=False
End Sub
Click to expand...

Thanks a lot Dave, exactly what I needed! 😀👍

/Skovgaard
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Copy Picture - VBA
2
Replies
10
Views
271
Logit
Logit
M
  • Question Question
Need help saving an already open pdf file using name from spreadsheet through VBA
Replies
6
Views
193
MatthewBiersay
M
M
  • Question Question
Data Transfer from Excel to PowerPoint and getting PDF file of PPT
Replies
1
Views
126
Sequoyah
Sequoyah
A
  • Solved
Using VBA to loop through multiple Word Templates and fill them in with Excel Data
2
Replies
14
Views
2K
John_w
J
J
  • Question Question
Parse HTML table or extract Outlook body items to excel sheet
Replies
2
Views
571
Jaffirahamed
J

Forum statistics

Threads
1,224,827
Messages
6,181,198
Members
453,022
Latest member
RobertV1609

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top