Sub SortTableByTitle()
Dim varTableKeys() As Variant
Dim varTemp As Variant
Dim lngIndex As Long, lngCompB As Long, lngCompA As Long
With ActiveDocument
ReDim varTableKeys(1 To .Tables.Count)
For lngIndex = 1 To .Tables.Count
'If the tables are actually titled i.e., .title property set to a text value, use:
varTableKeys(lngIndex) = .Tables(lngIndex).Title
'If you are depending on a cell content value as the title e.g., The first cell, use something like this:
'varTableKeys(lngIndex) = Trim(Left(.Tables(lngIndex).Cell(1, 1).Range.Text, Len(.Tables(lngIndex).Cell(1, 1).Range.Text) - 2))
Next
End With
'Sort the array\reposition tables
For lngIndex = LBound(varTableKeys) To UBound(varTableKeys) - 1
lngCompA = lngIndex
For lngCompB = lngIndex + 1 To UBound(varTableKeys)
If varTableKeys(lngCompB) < varTableKeys(lngCompA) Then lngCompA = lngCompB
Next
If lngCompA > lngIndex Then
'Swap table position in document
Swap_Posit lngIndex, lngCompA
'Swap position in array
varTemp = varTableKeys(lngIndex)
varTableKeys(lngIndex) = varTableKeys(lngCompA)
varTableKeys(lngCompA) = varTemp
End If
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Sub Swap_Posit(ByVal lngPositA As Long, ByVal lngPositB As Long)
'Swops position of two indexed tables in active document.
Dim oTblA As Table, oTblB As Table
Dim oRngA As Range, oRngB As Range, oRngTgt As Range
Dim lngIndex As Long
Set oTblA = ActiveDocument.Tables(lngPositA)
Set oTblB = ActiveDocument.Tables(lngPositB)
Set oRngA = oTblA.Range
Set oRngB = oTblB.Range
oRngA.Next.InsertBefore vbCr
Set oRngTgt = oRngA.Next.Next
oTblB.Range.Cut
oRngTgt.Collapse wdCollapseStart
oRngTgt.Paste
'Move the first table to the last position of second table
oTblA.Range.Cut
oRngB.Collapse wdCollapseStart
oRngB.Paste
oRngA.Delete
lbl_Exit:
Exit Sub
End Sub
