Dim pCell1 As Word.Cell
Dim pCell2 As Word.CellSub TableSorter()
Dim SourceTable As Table
Dim i As Long, j As Long, k As Long
Dim pTmpDoc As Word.Document
Dim pTmpTable As Table
Dim oRng As Word.Range
Dim myFrm As UserForm1
On Error GoTo Err_Handler
Set SourceTable = Selection.Tables(1)
i = SourceTable.Range.Cells.Count
Set myFrm = New UserForm1
myFrm.Show
'Create a temporary document and insert a 1
column/multi-row table
Set pTmpDoc = Documents.Add(Visible:=False)
Set pTmpTable = pTmpDoc.Tables.Add(pTmpDoc.Content, i, 1)
'Fill oTmpTable with contents of the table to
be sorted
TableFillAndRefill SourceTable, pTmpTable
'Sort the temporary table
pTmpTable.Sort
'Redefine source table contents based on sort
selected sort order
If myFrm.OptionButton1.Value = True Then
TableFillAndRefill pTmpTable, SourceTable
Else
With SourceTable
For i = 1 To .Range.Columns.Count
For j = 1 To
.Range.Rows.Count
k = k + 1
Set oRng = pTmpTable.Cell(k, 1).Range
.Cell(j, i).Range.Text = Left(oRng.Text, Len(oRng.Text) - 2)
Next j
Next i
End With
End If
'Clean up.
Unload myFrm
Set myFrm = Nothing
Set oRng = Nothing
pTmpDoc.Close SaveChanges:=False
Err_Handler:
If Err.Number = 5941 Then
MsgBox "The cursor must be positioned in the table you want
to sort." _
& vbCr & vbCr & " Position the cursor and run this procedure
again."
End If
End Sub
Sub TableFillAndRefill(pTable1 As Table, pTable2 As
Table)
'Copies tables cell for cell left to right
Dim pCell1 As Word.Cell
Dim pCell2 As Word.Cell
Set pCell1 = pTable1.Cell(1, 1)
Set pCell2 = pTable2.Cell(1, 1)
Do
pCell2.Range = Left$(pCell1.Range, Len(pCell1.Range) - 2)
Set pCell1 = pCell1.Next
Set pCell2 = pCell2.Next
Loop Until pCell1 Is Nothing
End Sub |
