Word VBA - Add column to the right end of a table

I have a document with nearly 1400 tables. The number of columns in each table is not always the same. Each table has a mixture of horizontally and vertically merged cells. I need to add a column to the right side of each table.

Note that I didn't write it from scratch, but I did modify it. Currently it only looks at the first table, once I get it working, I will loop it to change every table.

Edit 1:

The following error occurs at 't.Cell(r, 1).Select'

Runtime error '5941':
The requested member of the collection does not exist.

What I believe is happening is that I store the max number of rows used in 'q' and loop from the first row all the way to 'q'. The table I'm testing on has 6 maximum rows, but the first column has 1 cell as a title block and then a vertically merged cell that encompasses the remaining 5 rows.

Because 't.Cell(r, 1).Select' is using the first column, it gets to cell 3 in column 1, which doesn't exist because of the merged cells.

Any advice would be appreciated, thank you.

Sub Atest()
 
    Dim t As Table, r As Long, p As Long
    Set t = ActiveDocument.Tables(1)
    
    t.Cell(1, 1).Select                                         'select table first cell
    p = Selection.Information(wdMaximumNumberOfColumns)         'get current column count
    t.Cell(1, p).Select                                         'select table first row, last cell
    q = Selection.Information(wdMaximumNumberOfRows)            'get current row count
    
    For r = 1 To q
        t.Cell(r, 1).Select
        p = Selection.Information(wdMaximumNumberOfColumns)         'get column count of current row
        Debug.Print "the value of r is "; r
        Debug.Print "the value of p is "; p
        t.Cell(r, p).Select
        Selection.InsertCells (0)                                   'insert cell right
        
    Next r

End Sub

Edit 2:

This is the table I'm trying to add a column to. Table used for testing

Using the code below results in 2 columns being added to the beginning of the table, rather than one column at the end like I want. Table after running AddNewColumnToTable()

Sub AddNewColumnToTable()
    
    Dim t As Table
    
    Set t = ActiveDocument.Tables(1)
    t.Select
    Selection.Columns.Add
        
End Sub

Using this code results in two columns being added after the 2nd column. Table after running InsertNewColumnToTable()

Sub InsertNewColumnToTable()
    
    Dim t As Table
    
    Set t = ActiveDocument.Tables(1)
    t.Select
    Selection.InsertColumnsRight
        
End Sub

So far, Tim's solution Application.CommandBars.ExecuteMso "TableColumnsInsertRight" seems to be the best and most stable, fast.

Plz try my code to see:

• Without Collection, Save a loop:

Sub Word_VBA_Add_column_to_the_right_end_of_a_table()
    Dim tb As Word.Table, c As Word.Cell, ur As Word.UndoRecord, d As Word.Document, r As Byte
    Dim newColumnWidth As Single
    Set ur = Word.Application.UndoRecord
    ur.StartCustomRecord "Word_VBA_Add_column_to_the_right_end_of_a_table"
    Set d = ActiveDocument
    Word.Application.ScreenUpdating = False
    For Each tb In d.Tables
        For Each c In tb.Range.Cells
            If r = 0 Then
                r = c.RowIndex
            Else
                If c.RowIndex > r Then
                    If newColumnWidth = 0 Then newColumnWidth = c.Previous.Width
                    c.Previous.Range.Cells.Add.Width = newColumnWidth
                    r = c.RowIndex
                End If
                    
            End If
        Next c
        tb.Range.Cells(tb.Range.Cells.Count).Range.Cells.Add.Width = newColumnWidth
        r = 0: newColumnWidth = 0
    Next tb
    ur.EndCustomRecord
    Word.Application.ScreenUpdating = True
End Sub

Sub Word_VBA_Add_column_to_the_right_end_of_a_table()
    Dim tb As Word.Table, c As Word.Cell, ur As Word.UndoRecord, d As Word.Document, r As Byte, cln As New VBA.Collection
    Dim newColumnWidth As Single
    Set ur = Word.Application.UndoRecord
    ur.StartCustomRecord "Word_VBA_Add_column_to_the_right_end_of_a_table"
    Set d = ActiveDocument
    Word.Application.ScreenUpdating = False
    For Each tb In d.Tables
        For Each c In tb.Range.Cells
            If r = 0 Then
                r = c.RowIndex
            Else
                If c.RowIndex > r Then
                    cln.Add c.Previous
                    r = c.RowIndex
                End If
                    
            End If
        Next c
'        If newColumnWidth = 0 Then
            newColumnWidth = cln(1).Width ' set the new column's width value here
'        End If

        For Each c In cln
'            c.Select'just for test
            c.Range.Cells.Add.Width = newColumnWidth
        Next c
        tb.Range.Cells(tb.Range.Cells.Count).Range.Cells.Add.Width = newColumnWidth
        r = 0: Set cln = Nothing
    Next tb
    ur.EndCustomRecord
    Word.Application.ScreenUpdating = True
End Sub

This will insert a new cell to the right of the existing cell.
However, My previous solution had serious problems. This is because the inserted cells are actually inserted to the left of the existing cells, not to the right, which is not the far right side of the table.
So I have to move the content from the right of the new cell to the new one, and the problem above seems to be solved like this:

Sub Word_VBA_Add_column_to_the_right_end_of_a_table()
    Dim tb As Word.Table, c As Word.cell, ur As Word.UndoRecord, d As Word.Document, r As Byte, cln As New VBA.Collection
    Dim newCell As Word.cell
    Dim newColumnWidth As Single
    Set ur = Word.Application.UndoRecord
    ur.StartCustomRecord "Word_VBA_Add_column_to_the_right_end_of_a_table"
    Set d = ActiveDocument
    Word.Application.ScreenUpdating = False
    For Each tb In d.Tables
        For Each c In tb.Range.Cells
            If r = 0 Then
                r = c.RowIndex
            Else
                If c.RowIndex > r Then
                    cln.Add c.Previous
                    r = c.RowIndex
                End If
                    
            End If
        Next c
        For Each c In cln
            If newColumnWidth = 0 Then
                newColumnWidth = c.Width
            End If
            Set newCell = tb.Range.Cells.Add(c)
            newCell.Next.Width = newColumnWidth
            newCell.Next.Range.Cut: newCell.Range.Paste
'            newCell.Range.FormattedText = newCell.Next.Range.FormattedText
            'c.Range.Delete
        Next c
        Set newCell = tb.Range.Cells.Add(tb.Range.Cells(tb.Range.Cells.Count))
        newCell.Next.Width = newColumnWidth
        newCell.Next.Range.Cut: newCell.Range.Paste
        r = 0: Set cln = Nothing
    Next tb
    ur.EndCustomRecord
    Word.Application.ScreenUpdating = True
End Sub

Just insert/add a new cell after the last cell of each row.

Before:

After:

This works for me:

Sub Atest()
 
    Dim t As Table
    Set t = ActiveDocument.Tables(1)
    t.Columns.Add
    t.Columns.Autofit



End Sub

</details>