Is it possible to sort rows in a Microsoft WORD table without the data being sorted alphabetically,-CodePudding

It is a tricky question to ask, and I have not been able to even attempt using VBA code to try and figure this out. Using Table.Sort does not assist. Here is an example below if you are confused with what I require:

BEFORE            AFTER
rice              rice
pea               rice
apple             pea
vegetable         pea
vegetable         apple
pea               apple
apple             vegetable
rice              vegetable
orange            orange

As you can see above, although the data in the second column is sorted in an orderly fashion, it is not alphabetical. Is it possible to do this without having to place numbers in front of text in a column of a table then sort? Or without me having to do it all manually? My example above is a simple one, and for larger amounts of information, it would not be practical to do this manually. I can do what I require in EXCEL using formulas but I really need the word processing abilities of WORD rather than EXCEL.

CodePudding user response：

I had some free time, so I made a program to sort a table in Word based on my understanding of your sorting rules.

Sub Example()
    Call CustomSort(ThisDocument.Tables(1))
End Sub

Sub CustomSort(sortTable As Table)
    'Create an array that contains the table values
    Dim Items() As String
    ReDim Items(1 To sortTable.Rows.Count, 1 To sortTable.Columns.Count)
    
    Dim i As Long, j As Long
    For i = 1 To sortTable.Rows.Count
        For j = 1 To sortTable.Columns.Count
            Items(i, j) = sortTable.Cell(i, j).Range.Text
        Next j
    Next i

    'Sort the table
    Dim r As Long
    For i = 1 To UBound(Items, 1) - 2
        For r = i   2 To UBound(Items, 1)
            If Items(i, 1) = Items(r, 1) Then Call ArrayRowShift(Items, r, i   1)
        Next r
    Next i
    
    'Output the table
    For i = 1 To sortTable.Rows.Count
        For j = 1 To sortTable.Columns.Count
            sortTable.Cell(i, j).Range.Text = Items(i, j)
        Next j
    Next i
End Sub
Sub ArrayRowShift(ByRef Arr As Variant, RowIndex As Long, MoveTo As Long)
    'For 2D arrays, takes an array row, moves it to the specified index, returns the shifted array
    If RowIndex = MoveTo Then Exit Sub
    Dim tmpRow() As Variant
    ReDim tmpRow(LBound(Arr, 2) To UBound(Arr, 2))
    For j = LBound(Arr, 2) To UBound(Arr, 2)
        tmpRow(j) = Arr(RowIndex, j)
    Next j
    If RowIndex < MoveTo Then
        For i = RowIndex   1 To MoveTo
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                Arr(i - 1, j) = Arr(i, j)
            Next j
        Next i
    Else
        For i = RowIndex To MoveTo   1 Step -1
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                Arr(i, j) = Arr(i - 1, j)
            Next j
        Next i
    End If
    For j = LBound(Arr, 2) To UBound(Arr, 2)
        Arr(MoveTo, j) = tmpRow(j)
    Next j
End Sub

I take the table text into an array, re-arrange things in the array using VBA, then paste it back into the table. It works for any size of table in word (1D or 2D).

If you want to adjust the sorting rules, the line you need to edit is If Items(i, 1) = Items(r, 1) Then. You may want to add LCase around both, to remove case-sensitivity. Or Trim, to make sure excess white-space isn't preventing matches.

CodePudding user response：

For this code to work, you need this reference.
This is being run from Word VBA, not Excel.

Sub SortingSortOf()
Dim XL As Excel.Application, WB As Excel.Workbook
Dim WS As Excel.Worksheet, MatchCol As Excel.Range, Tbl As Table

    Set XL = Excel.Application
    Set WB = XL.Workbooks.Open("C:\Path\To\Workbook\With\YourTable.xlsm") ' or.xlsx
    Set WS = WB.Sheets("NameOfTableSheet")
    
    ' places a sort value one column to the right of the current data
    Set MatchCol = WS.UsedRange.Columns(WS.Cells.SpecialCells(xlCellTypeLastCell).Column   1)
    
    ' change this to whatever column holds your sort value
    MatchCol.Formula = "=Match(A1, A:A, 0)"
    
    ' i'm assuming you have some sort of header
    WS.UsedRange.Sort Key1:=MatchCol, Header:=xlYes
    
    'optional, unless you want the sort number displayed in the table
    MatchCol.Delete
    
     ' or wherever you want. doesn't have to be paragraph 1
    If ActiveDocument.Paragraphs(1).Range.Tables.Count > 0 Then
        For Each Tbl In ActiveDocument.Paragraphs(1).Range.Tables
            Tbl.Delete
        Next Tbl
    End If
    WS.UsedRange.Copy
    ActiveDocument.Paragraphs(1).Range.Paste
    
    ' putting false on close should prevent the save changes dialog,
    ' but there seems to be an excel bug, so shutting off alerts
    XL.DisplayAlerts = False
    WB.Close , False
    XL.DisplayAlerts = True
End Sub