Option Explicit
Dim m_oTbl As Word.Table
 
Sub SortTable()
  'Set the table object = the table with the selection
  On Error GoTo Err_Handler:
  Set m_oTbl = Selection.Tables(1)
  'Table must be uniform (not split or merged cells)
  If Not m_oTbl.Uniform Then
    MsgBox "The selected table has split or merge cells and cannot be sorted with this procedure", vbInformation + vbOKOnly, "Non-Uniform Table"
    Exit Sub
  End If
  TableSort_Re_Sort
  Exit Sub
Err_Handler:
  MsgBox "Select a table an try again.", vbInformation + vbOKCancel, "Table Not Selected"
End Sub
 
Sub TableSort_Re_Sort(Optional bTopToBottom As Boolean = True)
Dim oCell As Cell
Dim arrData() As String
Dim i As Long, j As Long, k As Long
 
  'Initialize the array with no elements
  ReDim arrData(i)
  'Load the array with data in table.  Skip loading empty cells
  For Each oCell In m_oTbl.Range.Cells
    If Left(oCell.Range, Len(oCell.Range) - 2) <> "" Then
      ReDim Preserve arrData(i)
      arrData(i) = Left(oCell.Range, Len(oCell.Range) - 2)
      i = i + 1
    End If
  Next
  'Sort the array
  WordBasic.SortArray arrData
  'Delete content of table
  m_oTbl.Range.Delete
  'Reset counter
  i = 0
  'Fill table with sorted results
  If bTopToBottom Then
    For k = 1 To m_oTbl.Columns.Count
      For j = 1 To m_oTbl.Rows.Count
        m_oTbl.Cell(j, k).Range.Text = arrData(i)
        'Get out when lasted array element has been inserted in table
        If i < UBound(arrData) Then
          i = i + 1
        Else
         GoTo lbl_Exit
        End If
      Next
    Next
  Else
    For Each oCell In m_oTbl.Range.Cells
      oCell.Range = arrData(i)
      'Get out when lasted array element has been inserted in table
      If i < UBound(arrData) Then
        i = i + 1
      Else
        GoTo lbl_Exit
      End If
    Next
  End If
lbl_Exit:
  Exit Sub
End Sub