Importing and formatting tables from Word to Excel using VBA

Question

Hi StackOverflow community. I am new at VBA coding and am trying to import table data from a Word document into Excel.

The number of tables in the Word document will be fixed at 5, and so will the number of rows and columns in each specific table.

I am having succes with importing all of the data, but the next step, where I would like to format the imported data, I can't seem to figure out.

Please see the inserted pictures below of the outcome that I get, and the outcome that I would like to get.

Output that I get

Output I would like to get

Please find the code that I have written below:

Sub CommandButton1_Click()
'Declare variables
    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim tableNo As Integer
    Dim irow As Long
    Dim icolumn As Long
    row_number = 1
    col_number = 1
    
    'Open specific Word-document to import table
    wdFileName = Application.GetOpenFilename("Word File(*.docx), *.docx", , "Select Word File", , False)
    
    If wdFileName = False Then Exit Sub
    
    Set wdDoc = GetObject(wdFileName)
    With wdDoc
        'Count the number of tables
        tableNo = .tables.Count
        If tableNo = 0 Then
            MsgBox "There are no tables in the specified Word Document. Please select the correct Word Document"
        Else
            'Import of text/data in the tables from Word-document to specified range in Excel. Starts with table 1, then 2 and so on
            For i = 1 To 1
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C6:D7").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C6:D7").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 2 To 2
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C7:D8").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C7:D8").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 2 To 2
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C8:D9").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 3).Range.Text)
                        Application.Range("C8:D9").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 4).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 3 To 3
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C9:D10").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 3).Value = WorksheetFunction.Clean(.cell(icolumn, 3).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 4).Value = WorksheetFunction.Clean(.cell(icolumn, 4).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 5).Value = WorksheetFunction.Clean(.cell(icolumn, 5).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 6).Value = WorksheetFunction.Clean(.cell(icolumn, 6).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 7).Value = WorksheetFunction.Clean(.cell(icolumn, 7).Range.Text)
                        Application.Range("C9:D10").Cells(col_number, 8).Value = WorksheetFunction.Clean(.cell(icolumn, 8).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 4 To 4
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C10:D11").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C10:D11").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
            For i = 5 To 5
                With .tables(i)
                    For icolumn = 1 To .Rows.Count
                        Application.Range("C11:D12").Cells(col_number, 1).Value = WorksheetFunction.Clean(.cell(icolumn, 1).Range.Text)
                        Application.Range("C11:D12").Cells(col_number, 2).Value = WorksheetFunction.Clean(.cell(icolumn, 2).Range.Text)

                        col_number = col_number + 1
                        row_number = row_number + 1
                    Next icolumn
                End With
            Next i
            
    End If
    End With
End Sub

I hope that the community can help with this :)

Dd you try copying the table range in word and then pasting as formatted text in Excel as described here https://stackoverflow.com/questions/12245525/how-to-preserve-source-formatting-while-copying-data-from-word-table-to-excel-sh — freeflow, Dec 09 '22 at 12:12
Hi @freeflow The thing is, I don't want to have to open up the Word-document and simply paste the tables into Excel. I have written the code so that it works with an ActiveX control button, so all I'll have to do is select the word document, and then everything will be imported to Excel. — zgk915, Dec 09 '22 at 12:56
As freeflow correctly pointed out the information you need can be found in the answer given in the linked question. — Timothy Rylatt, Dec 09 '22 at 13:06
Well I don't understand your comment as the first thing you do in the posted code is to access an open Word document. You need to read through the last part of the link where it demonstrated the cut and paste from excel to word. You can ignore all the preamble in the linked example which related to opening a word document as you already have an open word document. — freeflow, Dec 09 '22 at 13:16

score 0 · Accepted Answer · answered Dec 09 '22 at 14:17

Transpose rows and columns except for table 3.

Sub CommandButton1_Click()

    Dim wdDoc As Object, wdFileName As Variant, tbl As Word.Table
    Dim ws As Worksheet, rng As Range, tableNo As Integer
    Dim r As Long, c As Long
    
    'Open specific Word-document to import table
    wdFileName = Application.GetOpenFilename("Word File(*.docx), *.docx", , "Select Word File", , False)
    
    If wdFileName = False Then Exit Sub
    Set wdDoc = GetObject(wdFileName)
    
    'Count the number of tables
    tableNo = wdDoc.Tables.Count
    If tableNo < 5 Then
        MsgBox "There are not 5 tables in the specified Word Document. Please select the correct Word Document", vbExclamation
        Exit Sub
    End If
    
    Set ws = ActiveSheet 'ThisWorkbook.Sheet(1) '
    For tableNo = 1 To 5
        Set tbl = wdDoc.Tables(tableNo)
        
        Select Case tableNo
            Case 1:
                               
                Set rng = ws.Range("C6") ' top left corner
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 2
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
            Case 2:
                               
                Set rng = ws.Range("C9")
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 3
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
                Set rng = ws.Range("C12")
                ' transpose rows / cols
                For r = 3 To 4
                    For c = 1 To 3
                        rng.Offset(r - 3, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                 
            Case 3:
            
                Set rng = ws.Range("C17")
                For r = 1 To tbl.Rows.Count
                    For c = 1 To 8
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(r, c).Range.Text)
                    Next
                Next
                
            Case 4:
            
                Set rng = ws.Range("C26")
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 3
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
            Case 5:
            
                Set rng = ws.Range("C29")
                ' transpose rows / cols
                For r = 1 To 2
                    For c = 1 To 4
                        rng.Offset(r - 1, c - 1) = WorksheetFunction.Clean(tbl.cell(c, r).Range.Text)
                    Next
                Next
                
        End Select
        
    Next
    Set wdDoc = Nothing
    MsgBox "Done", vbInformation

End Sub

Importing and formatting tables from Word to Excel using VBA

1 Answers1