Word VBA - why the cell widths are not the same when changing table cell width

Question

I have a table with merged cell widths and heights so I can't access individual columns or rows. I have a loop that runs through the table to find the last cell in each row and that works fine. Once the last cell is found, I want to set the width so every final cell in each row is the same. This is a proof of concept and will be applied to other cells later.

When changing the cell width using the code below, the cell widths change to look like a stair step rather than being equivalent.

ActiveDocument.Tables(1).Cell(RowCurrent, ColCurrent).SetWidth _
ColumnWidth:=InchesToPoints(0.5), _
RulerStyle:=wdAdjustNone

Here is an image of the table prior to running the code.

Here is the table after running the code.

The final few rows do not need to be changed so there is no cell width changes made to those.

If anyone knows why the cell widths are not the same and how to fix it so they are it would be much appreciated, thank you!

Here is the full code in case it helps.

Sub SizeCells()
    
    Dim RowInd As Integer, ColInd As Integer
    Dim oCell As Cell, CellLast As Cell
    Dim RowCurrent As Integer, ColCurrent As Integer, ColLast As Integer
    Dim ArrayRowCount As Integer
    Dim MyArray() As Integer
    Dim counter As Integer

    ActiveDocument.Tables(1).Select

    With Selection.Find
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
        .Execute FindText:="potential assessment methods and objects"
    End With

    RowInd = Selection.Information(wdEndOfRangeRowNumber)
    ColInd = Selection.Information(wdEndOfRangeColumnNumber)

    'ActiveDocument.Tables(1).Cell(RowInd, ColInd).Select

    ArrayRowCount = -1

    For Each oCell In ActiveDocument.Tables(1).Range.Cells

        If oCell.RowIndex = RowInd And oCell.ColumnIndex = ColInd Then Exit For

        ArrayRowCount = ArrayRowCount + 1

    Next oCell

    ReDim MyArray(ArrayRowCount, 1)

    counter = 0

    For Each oCell In ActiveDocument.Tables(1).Range.Cells

        If oCell.RowIndex = RowInd And oCell.ColumnIndex = ColInd Then Exit For

        'Debug.Print oCell.RowIndex ; " "; oCell.ColumnIndex

        MyArray(counter, 0) = oCell.RowIndex
        MyArray(counter, 1) = oCell.ColumnIndex

        counter = counter + 1

    Next oCell

    For i = 0 To (ArrayRowCount - 1)
 
        RowCurrent = MyArray(i, 0)

        If RowCurrent <= MyArray(i + 1, 0) Then
            ColCurrent = MyArray(i, 1)

            'Last cell value in row has been found
            If ColCurrent > MyArray(i + 1, 1) Then
                ActiveDocument.Tables(1).Cell(RowCurrent, ColCurrent).SetWidth _
                ColumnWidth:=InchesToPoints(0.5), _
                RulerStyle:=wdAdjustNone

            End If
        End If

    Next i
    
End Sub

Answer 1

The code used was not the issue. Turns out the first table was the only table that had the option 'Automatically resize to fit contents' still checked. I realized this after using the code taller_ExcelHome suggested and having the same issue occur.

I'm marking this answer as the correct one but taller_ExcelHome's code is more efficient and taught me about the use of dictionaries so a thank you to them for the help!

Answer 2

Loop through Word table (with merged cells) Cells collection storing last cell of each row in a dictionary.

Sub demo()
    Dim oCell As cell, wdRng As Object
    Dim oDic As Object, vKey
    Dim oTab As Table
    Set oDic = CreateObject("scripting.Dictionary")
    Set oTab = ActiveDocument.Tables(1)
    With oTab.Range
        For Each oCell In .Cells
            With oCell
                If oDic.Exists(.rowIndex) Then
                    If oDic(.rowIndex) < .ColumnIndex Then _
                        oDic(.rowIndex) = .ColumnIndex
                Else
                    oDic(.rowIndex) = .ColumnIndex
                End If
            End With
        Next
    End With
    For Each vKey In oDic.keys
        oTab.cell(vKey, oDic(vKey)).SetWidth _
                ColumnWidth:=InchesToPoints(0.5), _
                RulerStyle:=wdAdjustNone
    Next
End Sub