Why rows get deleted after the sorting

I've a script which is sorting the tables in Word using the order from Excel correctly but after sorting the rows gets deleted.

I used ctrl z to see what happened step by step-

1. rows started getting deleted from last row to 3.
2. after deletion rows started getting added from row 3 in proper order as I wanted.
3. after all rows added with proper order, the rows started getting deleted from the last row to row 3.

Why the rows started getting deleted once the rows are added in a proper order. It should not be deleted after the sorting is done, means rows are added.

What can I try next?

Sub SortSelectedTablesUsingExcelOrder()

    Dim wdDoc As Document
    Dim wdTable As table
    Dim excelApp As Object
    Dim excelWorkbook As Object
    Dim excelSheet As Object
    Dim sortOrder() As String
    Dim i As Long, j As Long
    Dim cellValue As String
    Dim rowIndex As Long
    Dim newRow As row
    Dim colCount As Long
    Dim fileDialog As fileDialog
    Dim filePath As String
    Dim lastRow As Long
    Dim matchedRows As Collection
    Dim rowText As Variant
    Dim tableCellValue As String

    Set wdDoc = ActiveDocument

    ' File selection dialog for Excel file
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Title = "Select the Excel File"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm", 1
        .AllowMultiSelect = False
        If .Show = -1 Then
            filePath = .SelectedItems(1)
        Else
            MsgBox "No file selected. Exiting.", vbExclamation
            Exit Sub
        End If
    End With

    ' Initialize Excel application
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = False
    Set excelWorkbook = excelApp.Workbooks.Open(filePath)
    Set excelSheet = excelWorkbook.Sheets(2)

    lastRow = excelSheet.Cells(excelSheet.Rows.Count, 1).End(-4162).row

    ' Load Excel order into sortOrder array
    ReDim sortOrder(1 To lastRow)
    For i = 1 To lastRow
        sortOrder(i) = UCase(excelSheet.Cells(i, 1).Value) ' Convert to uppercase
        Debug.Print "Excel Order " & i & ": " & sortOrder(i) ' Print Excel order in Immediate Window
    Next i

    ' Process Word tables
    For Each wdTable In wdDoc.Tables
        If UCase(Trim(wdTable.cell(1, 1).Range.Text)) Like "*PARTS REQUIRED*" Then ' Convert table title to uppercase
            colCount = wdTable.Columns.Count
            Set matchedRows = New Collection

            ' Gather matched rows from the Word table
            For i = 1 To lastRow
                cellValue = sortOrder(i)
                Debug.Print "Processing Excel Value: " & cellValue ' Print currently processing Excel value

                For rowIndex = 3 To wdTable.Rows.Count
                    tableCellValue = UCase(Left(wdTable.cell(rowIndex, 1).Range.Text, Len(wdTable.cell(rowIndex, 1).Range.Text) - 2)) ' Convert to uppercase

                    If tableCellValue = cellValue Then
                        rowText = ""

                        ' Collect the data from the matched row
                        For j = 1 To colCount
                            rowText = rowText & wdTable.cell(rowIndex, j).Range.Text & vbTab
                        Next j
                        rowText = Left(rowText, Len(rowText) - 1)
                        matchedRows.Add rowText

                        ' Print matched row
                        Debug.Print "Matched Row " & rowIndex & ": " & rowText
                    End If
                Next rowIndex
            Next i

            ' Now, clear the table and add the rows back in the correct order
            For rowIndex = wdTable.Rows.Count To 3 Step -1
                wdTable.Rows(rowIndex).Delete
            Next rowIndex

            ' Insert rows back based on the matched order
            For Each rowText In matchedRows
                Set newRow = wdTable.Rows.Add

                Dim rowData() As String
                rowData = Split(rowText, vbTab)

                For j = 1 To colCount
                    newRow.Cells(j).Range.Text = rowData(j - 1)
                Next j

                ' Print new row data after insertion
                Debug.Print "Inserted Row: " & Join(rowData, vbTab)
            Next rowText
        End If
    Next wdTable

    ' Clean up the Word table content
    For Each wdTable In wdDoc.Tables
        tableTitle = UCase(Trim(wdTable.cell(1, 1).Range.Text)) ' Convert title to uppercase
        tableTitle = Left(tableTitle, Len(tableTitle) - 2)

        If tableTitle = "PARTS REQUIRED" Then
            For Each tableCell In wdTable.Range.Cells
                tableCell.Range.Text = Replace(tableCell.Range.Text, vbCr, "")
            Next tableCell
        End If
    Next wdTable

    ' Close Excel
    excelWorkbook.Close SaveChanges:=False
    excelApp.Quit
    Set excelApp = Nothing
    Set excelWorkbook = Nothing
    Set excelSheet = Nothing
    Set wdDoc = Nothing

End Sub

Here's a different approach which is easier (I think) to manage: pull the table content into a 2D array and then add that back according to the sort order array.

Easier to deal with since it doesn't delete anything, only overwrites. Also (optional) catches rows not found in the sort order list and adds them last...

I hardcoded the sort order array to keep the focus on the actual sorting.

Unsorted and sorted tables:

Sub SortSelectedTablesUsingExcelOrder()

    Dim wdDoc As Document, tbl As Table
    Dim i As Long, data, sortList, currRow As Long, r As Long
    
    Set wdDoc = ActiveDocument
    
    'hard-coding this for testing...
    sortList = Array("Val006", "Val003", "Val002", "Val001", "Val005") 'note no "Val004"
    
    ' Process Word tables
    For Each tbl In wdDoc.Tables
        If UCase(Trim(tbl.Cell(1, 1).Range.Text)) Like "*PARTS REQUIRED*" Then ' Convert table title to uppercase
            data = DataFromTable(tbl, 3) 'get 2D array of table data starting from 3rd row
            currRow = 3
            'Re-populate rows according to the sort list order
            For i = LBound(sortList) To UBound(sortList)
                For r = 1 To UBound(data)
                    If data(r, 1) = sortList(i) Then
                        ArrayToRow tbl, data, currRow, r 'put array "row" to table row
                        currRow = currRow + 1   'next row to fill
                        data(r, 1) = "*added*"  'flag as added
                    End If
                Next r
            Next i
            'Add any remaining rows not matched to the sort list
            For r = 1 To UBound(data)
                If data(r, 1) <> "*added*" Then      'not already copied back
                    ArrayToRow tbl, data, currRow, r 'array "row" to table row
                    currRow = currRow + 1            'next row to fill
                End If
            Next r
        End If 'processing this table
    Next tbl
    
End Sub

'Populate a table row (#rDest) from a specified row `rSrc` in a 2D array `data`
Sub ArrayToRow(tbl As Word.Table, data, rDest As Long, rSrc As Long)
    Dim c As Long
    For c = 1 To UBound(data, 2)
        tbl.Cell(rDest, c).Range.Text = data(rSrc, c)
    Next c
End Sub

'grab the content of a table as a 2-D array, starting at row `rowStart`
Function DataFromTable(tbl As Table, rowStart As Long)
    Dim numCols As Long, numRows As Long, c As Long, r As Long, data, txt
    numRows = tbl.rows.Count
    numCols = tbl.Columns.Count
    ReDim data(1 To numRows - (rowStart - 1), 1 To numCols)
    For r = rowStart To numRows
        For c = 1 To numCols
            txt = tbl.Cell(r, c).Range.Text
            data(r - (rowStart - 1), c) = Left(txt, Len(txt) - 2) 'remove end-of cell marker
        Next c
    Next r
    DataFromTable = data
End Function