Formatting a word table created in excel using VBA

Question

I have a table like this excel table and I want to create a Word Table to look like this

I am a novice user of VBA so this is genuinely killing me because I can't figure out how to make this happen.

My output so far has been this here. As you can see, I am nowhere near this and I would like some help on formatting it right.

My code is below:

Sub Rev2()


Dim objWord As Object
Dim objDoc As Object
Dim objSelection As Object
Dim wSheet As Worksheet


Dim excel_rows As Integer 'Excel r
Dim excel_cols As Integer 'Excel c
Dim word_rows As Integer 'Word R


Dim wRow As Integer
Dim wCol As Integer
Dim i As Integer


Set wSheet = ThisWorkbook.Worksheets("Sheet1")
wSheet.Activate

excel_rows = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
excel_cols = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
Set objSelection = objWord.Selection

objWord.Visible = True
objWord.Activate


word_rows = (excel_rows * 3)

Set overstockTable = objDoc.Tables.Add(objSelection.Range, word_rows, 1)




With overstockTable

    
    .Borders.Enable = True
    .Range.Font.Bold = True
    

    'Split every 3rd cell into 3 columns
    For i = 1 To word_rows
        If i Mod 3 = 0 Then
            .Cell(i, 1).Split NumColumns:=3

        End If
    Next i


    
    'Transfer data
    For wRow = 1 To word_rows

        Debug.Print ("wRow is " & wRow)
        
        If wRow Mod 3 <> 0 Then
            
            'Read the active cell from excel and transfer it to the word table
            .Cell(wRow, 1).Range.InsertAfter wSheet.Cells(ActiveCell.row, ActiveCell.Column).Text
            .Cell(wRow, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            ActiveCell.Offset(0, 1).Select
            
            
            
        Else
            
            For wCol = 1 To 3
                
                .Cell(wRow, wCol).Range.InsertAfter wSheet.Cells(ActiveCell.row, ActiveCell.Column).Text
                .Cell(wRow, wCol).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
                ActiveCell.Offset(0, 1).Select
                
                If wCol Mod 3 = 0 Then
                    
                    ActiveCell.Offset(1, -5).Select
                
                End If
                    
            Next wCol
            
        End If
    
    
    Next wRow
    

    
End With


End Sub

Problems I encounter:

Reading the Databody only. I don't know how to start reading from A2 and below. I use offset when pasting data from the excel to the word document. I am hoping to know if there's a better way to do this.
Paragraph Formatting inside the cells. I have been trying to center align all the cells in the word document instead of the default left-align. In my code you will notice while I am transferring the data, that I try to align the cells, but it doesn't work and I have no idea why.

Any tips will be greatly appreciated. Thank you in advance!

What will the output be if there’s more than one "Home Location"? Also, where does "Initials" come from? It doesn’t appear to be part of the source table. — taller
– taller, Commented Jul 29 at 3:46
@taller I am guessing you mean the Overstock Location ? The table is meant to be a summary for one overstock location that comprises items belonging to different home locations. Apologies for the Initials, that is something I want to manually add to the document for now unless I figure out how to add this through a userform. — generalzu10
– generalzu10, Commented Jul 29 at 3:57
Yes. I meant Overstock Location. Please try the script in my post below and let me know if the output matches your expectations. — taller
– taller, Commented Jul 29 at 4:26

taller · Accepted Answer · 2025-07-29 04:37:18Z

Please try the following script — it will create a Word table as shown in your original post.


Sub Excel2Word()
    Dim ws As Worksheet
    Dim wdDoc As Object
    Dim wdApp As Object
    Dim i As Long, j As Long
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application") ' get the opened Word App
    On Error GoTo 0
    If wdApp Is Nothing Then
        On Error Resume Next
        Set wdApp = CreateObject("Word.Application") ' open a new app
        On Error GoTo 0
    End If
    If wdApp Is Nothing Then
        MsgBox "Microsoft Word is not installed or accessible.", vbExclamation
        Exit Sub
    End If
    wdApp.Visible = True
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ' get the source table on worksheet
    Dim oTab As ListObject
    If ws.ListObjects.Count = 0 Then
        Set oTab = ws.ListObjects.Add(xlSrcRange, ws.Range("A1").CurrentRegion, , xlYes)
    Else
        Set oTab = ws.ListObjects(1)
    End If
    ' rows count of Word table
    Dim RowCnt As Long:  RowCnt = oTab.ListRows.Count * 3 + 1
    Set wdDoc = wdApp.Documents.Add
    Dim wdTab As Object
    Set wdTab = wdDoc.Tables.Add(Range:=wdDoc.Range, NumRows:=RowCnt, _
        NumColumns:=1, DefaultTableBehavior:=1, AutoFitBehavior:=0)
    With wdTab.Range
        .ParagraphFormat.Alignment = 1 ' change to center alignment
        .Font.Bold = True ' apply Bold for Word table
    End With
    For i = 3 To RowCnt Step 3
        wdTab.cell(i, 1).Split 1, 3 ' split the cell
        wdTab.Rows(i).Borders(-6).LineStyle = 0 'wdLineStyleNone remove the vertical line
    Next
    wdTab.cell(RowCnt, 1).Split 1, 3
    wdTab.Rows(RowCnt).Borders(-6).LineStyle = 0
    Dim arr: arr = oTab.DataBodyRange.Value ' load source table into an array
    ' populate Word table
    For i = 1 To oTab.ListRows.Count
        With wdTab.cell(i * 3 - 2, 1).Range
            .Text = arr(i, 1)
            .Font.Size = 16 ' change font size, modify as needed
        End With
        With wdTab.cell(i * 3 - 1, 1).Range
            .Text = arr(i, 2)
            .Font.Size = 12
        End With
        For j = 1 To 3
            wdTab.cell(i * 3, j).Range.Text = arr(i, j + 2)
        Next
    Next
    ' populate the last row in Word table
    wdTab.cell(RowCnt, 1) = arr(1, 6)
    wdTab.cell(RowCnt, 2) = "Initials" ' modify as need
    wdTab.cell(RowCnt, 3) = Format(Date, "mmmm dd, yyyy") ' format date
    wdDoc.SaveAs ThisWorkbook.Path & "\WordTable.docx" ' save Word doc.
    ' wdDoc.Close ' Close Word doc.
    MsgBox "Task completed.", vbInformation
End Sub

this works for me! I didn't realize that I could use ListObjects instead which seems to work much better. Plus it leaves room for adjustments to be made too. Thanks a lot !

Collectives™ on Stack Overflow

Formatting a word table created in excel using VBA

1 Answer 1

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related