Merge cells in a 1x12 table vertically into blocks of three

Question

I have a table in MS word. It is 1 cell wide by 12 cells down, each containing a number. I want to use VBA to merge the 12 cells into 4 cells containing 3 numbers.

So if the 12 cells each contain the numbers 1 to 12, I want to end up with 4 cells. Cell 1 contains 1 2 3 Cell 2 contains 4 5 6 Cell 3 contains 7 8 9 Cell 4 contains 10 11 12

I've asked ChatGPT to write the code, and after correcting its errors, I have this:

Sub MergeCellsVertically()
    Dim tbl As Table
    Dim i As Integer
    
    ' Set tbl to the first table in the document
    Set tbl = ActiveDocument.Tables(1)
    
    ' Loop through each row in the table
    For i = 1 To tbl.Rows.Count 'Step 3
        ' Check if there are at least three rows remaining
        If i + 2 <= tbl.Rows.Count Then
            ' Merge the cells in the first column
            tbl.Cell(i, 1).Merge tbl.Cell(i + 1, 1)
            tbl.Cell(i, 1).Merge tbl.Cell(i + 2, 1)
        End If
    Next i
End Sub

But this gives me 3 cells containing 4 numbers: 1 2 3 4 5 6 7 8 9 10 11 12. I've tried playing with the parameters in the code but I can't get it to merge the 12 into 4 blocks of 3, only 3 blocks of 4. I'm obviously missing something obvious, but what?

Answer 1

This is the edited version

Sub MergeCellsVertically()
    Dim tbl As Table
    Dim i As Integer
    
    ' Set tbl to the first table in the document
    Set tbl = ActiveDocument.Tables(1)
    
    ' Loop through each row in the table
    For i = 1 To tbl.Rows.Count 'Step 3
        ' Check if there are at least three rows remaining
        If i + 2 <= tbl.Rows.Count Then
            ' Merge the cells in the first column
            tbl.Cell(i, 1).Merge tbl.Cell(i + 2, 1)   
            'tbl.Cell(i, 1).Merge tbl.Cell(i + 1, 1)  'removed from code
        End If
    Next i
End Sub