Formatting a word table created in excel using VBA

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:

1. 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.
2. 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!

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