VBA - Import multiple tables from Word

S

Skovgaard

Board Regular
Joined
Oct 18, 2013
Messages
197
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
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
Seems like this should work. HTH. Dave
Code: 
Dim LR As Long, 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)
LR = 4
Dim fil As Object
ActiveSheet.Range("A4:AZ10000").ClearContents
'open Word application
On Error Resume Next
Set WrdObj = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WrdObj = CreateObject("Word.Application")
End If
For Each fil In fold.Files
    ImportWordTable fil.path, LR
WrdObj.Activedocument.Close savechanges:=False
Next fil
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

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
        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
                    ActiveSheet.Cells(resultRow, iCol) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                Next iCol
                resultRow = resultRow + 1
            Next iRow
        End With
        resultRow = resultRow + 1
    Next tableStart
End With
LR = resultRow
End Sub
 
Upvote 0
NdNoviceHlp said:
Seems like this should work. HTH. Dave
Code: 
Dim LR As Long, 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)
LR = 4
Dim fil As Object
ActiveSheet.Range("A4:AZ10000").ClearContents
'open Word application
On Error Resume Next
Set WrdObj = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WrdObj = CreateObject("Word.Application")
End If
For Each fil In fold.Files
    ImportWordTable fil.path, LR
WrdObj.Activedocument.Close savechanges:=False
Next fil
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

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
        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
                    ActiveSheet.Cells(resultRow, iCol) = Application.WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                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,
Thanks, but unfortunately it seems to give the same result, as my original code, see below.

1653389037423.png


The final result should look like below, only one row per table, and if possible only the cells, that I marked yellow.
If not possible to pick those cells - I just delete the columns afterwards.

1653389085118.png


/Skovgaard
 
Upvote 0
Hi Skovgarrd. Your table(s) in the Word docs seems to have all of the area "Test Results" (ie. the mineral contents) in 1 cell? I'm not sure how you resolve that unless there is some hidden character that separates the data that you could use to split the 1st table cell into separate results. I didn't quite follow your output requirements before about each table on a separate row in XL and transferring only the highlighted values. Seems like that should be doable. Getting only the highlighted values of the second area ("Sample information" ) is fairly straight forward. Only transfer the table information from table columns 2,4 & 6. But that comes after figuring out what to do with table cell 1. You might want to trial the following to find out if there are any separation characters in the 1st table cell...
Code: 
With .tables(tableStart)
For i = 1 To Len(.cell(1, 1).Range.Text)
MsgBox Asc(Mid(.cell(1, 1).Range.Text, i, 1))
Next i
Include the code after your With .tables(tablestart) as shown. It will be quite boring as it will loop through all of the characters in the string and msgbox U all of their ascii numbers. Check and see if 12 or 13 or some other ascii number separates each result. HTH. Dave
 
Upvote 0
NdNoviceHlp said:
Hi Skovgarrd. Your table(s) in the Word docs seems to have all of the area "Test Results" (ie. the mineral contents) in 1 cell? I'm not sure how you resolve that unless there is some hidden character that separates the data that you could use to split the 1st table cell into separate results. I didn't quite follow your output requirements before about each table on a separate row in XL and transferring only the highlighted values. Seems like that should be doable. Getting only the highlighted values of the second area ("Sample information" ) is fairly straight forward. Only transfer the table information from table columns 2,4 & 6. But that comes after figuring out what to do with table cell 1. You might want to trial the following to find out if there are any separation characters in the 1st table cell...
Code: 
With .tables(tableStart)
For i = 1 To Len(.cell(1, 1).Range.Text)
MsgBox Asc(Mid(.cell(1, 1).Range.Text, i, 1))
Next i
Include the code after your With .tables(tablestart) as shown. It will be quite boring as it will loop through all of the characters in the string and msgbox U all of their ascii numbers. Check and see if 12 or 13 or some other ascii number separates each result. HTH. Dave
Click to expand...
Hi Dave,
It was quite boring 🥴 I've been though all the ascii number, till the first yellow cell (ascii 51 = 3). I haven't been working with ascii numbers before, but as I can see it, the separator used is "13". I'm not sure if you can use it, but I counted 22 ascii number=13, before I got to the desired cell.

/Skovgaard
 
Upvote 0
If I understand your outcome correctly, this should start with msgboxes indicating your mineral numbers (ie 35.15). Again a bit tedious, place this in the same spot as before. Dave
Code: 
Dim SplitTemp As Variant, Cnt As Integer

With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = 22 To UBound(SplitTemp)
MsgBox SplitTemp(Cnt)
Next Cnt
 
Upvote 0
NdNoviceHlp said:
If I understand your outcome correctly, this should start with msgboxes indicating your mineral numbers (ie 35.15). Again a bit tedious, place this in the same spot as before. Dave
Code: 
Dim SplitTemp As Variant, Cnt As Integer

With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = 22 To UBound(SplitTemp)
MsgBox SplitTemp(Cnt)
Next Cnt
Click to expand...
Hi Dave,

Sorry for my late reply - Its been a long weekend.
The msgbox gives me the correct mineral number, see below.

1653891221467.png


/Skovgaard
 
Upvote 0
Seems like were on the right track. We need to know the location of the rest of those numbers. So trial this and report back the "Cnt" numbers that provide the mineral numbers. It should be 22-30 to start with and then 2 sets of other numbers. Dave
Code: 
Dim SplitTemp As Variant, Cnt As Integer
With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = 22 To UBound(SplitTemp)
MsgBox "Cnt " & Cnt & "    " & SplitTemp(Cnt)
Next Cnt
 
Upvote 0
NdNoviceHlp said:
Seems like were on the right track. We need to know the location of the rest of those numbers. So trial this and report back the "Cnt" numbers that provide the mineral numbers. It should be 22-30 to start with and then 2 sets of other numbers. Dave
Code: 
Dim SplitTemp As Variant, Cnt As Integer
With .tables(tableStart)
SplitTemp = Split(.cell(1, 1).Range.Text, Chr(13))
For Cnt = 22 To UBound(SplitTemp)
MsgBox "Cnt " & Cnt & "    " & SplitTemp(Cnt)
Next Cnt
Click to expand...
Agree, seems like we're on the right track 👍😊
The numbers are counted like this: 22-30, 42-50 and 62-68.

/Skovgaard
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Creating a Train Time Table
2 3
Replies
29
Views
2K
I_know_nuffin
I
J
  • Question
Parse HTML table or extract Outlook body items to excel sheet
Replies
2
Views
219
Jaffirahamed
J
R
  • Question
Enhancement for folder/file/subfolder lookup automation
Replies
3
Views
237
rawr19911
R
R
  • Solved
VBA question
2
Replies
13
Views
597
rawr19911
R
X
  • Question
vba get html table vale to excel
Replies
1
Views
199
Fluff
Fluff

Forum statistics

Threads
1,214,932
Messages
6,122,332
Members
449,077
Latest member
jmsotelo

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