Automate data export from multiple word tables into excel

[andrewhoddie]

Hi

I am looking to automate a process as best I can. I have a word document which has a number of different tables in it. These tables are used to collect data and can vary in size and have automated numbering which continues over the different tables.

The current process involves me completing the tables in word and then manually copying a number of rows of data from word into excel which is very time consuming. The data does need to be in multiple tables as we break the report down into different headings for the end user and we can present it so ideally the section does not go over a page break.

The word document is made up of a mix of text and tables and it is only certain tables I need to extract. Is it possible to take the data from each of these different tables and automatically populate one excel sheet?

Just to complicate things further I ideally only want to bring through data from Columns 1,3,4,5
Column 1 = auto numbering (number)
Column 3 = Recommendation (text)
Column 4 = rating (this is currently an icon)
Column 5 = rating size (text)

These would go into the following columns in excel

Column 1 - A
Column 3 - B
Column 4 - C
Column 5 - E

I dont know if this would also be possible to do but if the text in column 3 said something like "No Action" this row is excluded from the export that would also be amazing but that would be an ideal world.

If there are changes I can make to the word document I am willing to consider this but I cant guarantee the boss will agree.

Any help gratefully accepted.

many thanks

 

[NdNoviceHlp]

Hi andrewhoddie. This code assumes that you want data from every table and that the only pics in the document are in the table(s). You will need to adjust the file path for the document. Save your wb before testing. HTH. Dave

Sub test2()
Dim WordApp As Object, TableTot As Integer, TableStart As Integer
Dim irow As Integer, icol As Integer, TableColArr As Variant
Dim ws As Worksheet, ColCnt As Integer, RowCnt As Integer, ishp As Variant

'create Word app
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set WordApp = CreateObject("Word.Application")
End If
On Error GoTo 0
'show Word doc and leave open
WordApp.Visible = True
'********adjust file path to suit
WordApp.Documents.Open ("C:\Testfolder\testdoc.docx")

TableColArr = Array(1, 3, 4, 5) 'table columns
Set ws = ActiveWorkbook.Sheets("Sheet1")
RowCnt = 1 'sheet start row
With WordApp.ActiveDocument
    TableTot = .Tables.Count
'loop tables
    For TableStart = 1 To TableTot
        'output tbl by row contents
        With .Tables(TableStart)
            For irow = 1 To .Rows.Count ' table rows
                'skip table rows with 3rd col "No Action"
                If Application.WorksheetFunction.Clean(.cell(irow, 3).Range.Text) <> "No Action" Then
                ColCnt = 0 'sheet columns
                For icol = LBound(TableColArr) To UBound(TableColArr) 'table columns
                ColCnt = ColCnt + 1
                If ColCnt <> 3 Then 'move text to sheet
                ws.Cells(RowCnt, ColCnt) = Application.WorksheetFunction.Clean(.cell(irow, TableColArr(icol)).Range.Text)
                Else 'copy pic to sheet
                If Application.WorksheetFunction.Clean(.cell(irow, TableColArr(icol)).Range.Text) <> vbNullString Then
                Set ishp = WordApp.ActiveDocument.InlineShapes(irow)
                ishp.Range.CopyAsPicture
                ws.Cells(RowCnt, ColCnt).PasteSpecial
                Application.CutCopyMode = False
                End If
                End If
                Next icol
                End If
            RowCnt = RowCnt + 1 'sheet rows
            Next irow
        End With
    Next TableStart
End With
'unselect pic
ws.Cells(1, 1).Select
End Sub