Table Sort Macro

[gmaxey]

A while back I wrote some code to sort table contents top to bottom/left to right. Today I noticed that if there are empty cells in the table then the results are not as expected. For exmple if I have 5 x 5 table with a - y entered right to left top to bottom in the cells and run the code the results is a-z ordered top to bottom left to right.

However, if i have the same table with only a and b in A1 and B1 and run the code "a" appears in E4 and "b" in E5 where "a" should appear in A1 and "b" in A2.

I know what is going on so a a fix I cobbled:

Sub SortTable()
Dim oTbl As Table
Dim oCell As Word.Cell
Dim i As Long, j As Long, k As Long
Dim strTemp As String
Dim arrData() As String
Application.ScreenUpdating = False
Set oTbl = Selection.Tables(1)
i = oTbl.Range.Cells.Count
ReDim arrData(i - 1)
Set oCell = oTbl.Cell(1, 1)
i = 0
Do
strTemp = Left$(oCell.Range, Len(oCell.Range) - 2)
If strTemp = "" Then strTemp = "ZzZzZz"
arrData(i) = strTemp
'arrData(i) = Left$(oCell.Range, Len(oCell.Range) - 2)
Set oCell = oCell.Next
i = i + 1
Loop Until oCell Is Nothing
'Sort the array
WordBasic.SortArray arrData
With oTbl
k = 0
For i = 1 To .Range.Columns.Count
For j = 1 To .Range.Rows.Count
.Cell(j, i).Range.Text = arrData(k)
k = k + 1
Next j
Next i
End With
'Clean up.
With oTbl.Range.Find
.Text = "ZzZzZz"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
Set oTbl = Nothing
Application.ScreenUpdating = True
lbl_Exit:
Exit Sub
End Sub


Can anyone suggest a better way? Is there a way to sort the array such that empty elements come after elements with text? Thanks.

[Frosty]

How ironic that you happen to be working on a sort function just as I was dealing with array sorting in my own work. Couple of things I learned....

1. The WordBasic.SortArray function has limitations. Something about it truncating strings when sorting anything over 256 characters.

2. The most common sort you'll find, when looking for a replacement to WordBasic.SortArray is going to be something called a BubbleSort. It seems that most people think the BubbleSort method stinks.

3. Here are some generic bits of code I found (and adjusted to my style, which I know you'll love :-D) for sorting arrays and testing different sorting methods (I put this code in a module called Utilities_Arrays). The SortingTester procedure is sort of the demo, although it requires using the Locals Window to see what's going on (I didn't bother with output to a document).

Option Explicit
'This module is for dealing with arrays, instead of always doing google searches on the subject
Public Enum ArraySortMethods
BubbleSort
QuickSort
QuickSortMulti1
QuickSortMulti2
End Enum
'Various function returns
Public Enum FunctionReturn
errorResumeExit = 1
errorResumeNext = 2
errorStop = -10
FAILURE = -1000
SUCCESS = 1000
USERCANCEL = -1001
End Enum
Private Sub SortingTester()
Dim aryTest As Variant

'bubble test
aryTest = fSampleArray_Simple
Stop
SortThisArray aryTest, BubbleSort
Stop

'quick sort test
aryTest = fSampleArray_Simple
Stop
SortThisArray aryTest, QuickSort
Stop

'multisort test
aryTest = fSampleArray_MultiSingle
Stop
SortThisArray aryTest, QuickSortMulti1, True, 0
Stop

End Sub
'central routine for sorting an array
Public Function SortThisArray(aryToSort As Variant, _
lMethod As ArraySortMethods, _
Optional bAscending As Boolean, _
Optional lPrimarySort As Long, _
Optional lSecondarySort As Long) As FunctionReturn

On Error GoTo l_err

Select Case lMethod
Case BubbleSort
Sort_Bubble aryToSort

Case QuickSort
Sort_Quick aryToSort, _
LBound(aryToSort), _
UBound(aryToSort)

Case QuickSortMulti1
Sort_Quick_MultiSingle aryToSort, _
LBound(aryToSort, 2), _
UBound(aryToSort, 2), _
lPrimarySort, _
bAscending

'haven't tested this yet
Case QuickSortMulti2
'Sort_Quick_MultiTwo aryToSort, _
LBound(aryToSort, 2), _
UBound(aryToSort, 2), _
lPrimarySort, _
lSecondarySort, _
bAscending
Case Else
'do nothing with it
SortThisArray = FAILURE
GoTo l_exit
End Select
'if no errors...
SortThisArray = SUCCESS
l_exit:
Exit Function
l_err:
SortThisArray = FAILURE
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------
' Bubble Sort method
' pass in an array, returns as an alphanumeric ascended array
'----------------------------------------------------------------------------------------------
Public Sub Sort_Bubble(arySort As Variant)

Dim iFirst As Integer
Dim iLast As Integer
Dim i As Integer
Dim x As Integer
Dim sTemp As String

iFirst = LBound(arySort)
iLast = UBound(arySort)
For i = iFirst To iLast - 1
For x = i + 1 To iLast
If arySort(i) > arySort(x) Then
sTemp = arySort(x)
arySort(x) = arySort(i)
arySort(i) = sTemp
End If
Next x
Next i

End Sub
'----------------------------------------------------------------------------------------------
' Quick Sort method, uses recursive method
' pass in the lbound and the ubound of the array in the calling procedure
' ex: Sort_Quick myArray, lbound(myArray), ubound(myArray)
'----------------------------------------------------------------------------------------------
Private Sub Sort_Quick(ByRef arySort As Variant, _
ByVal lFirst As Long, _
ByVal lLast As Long)
Dim lLow As Long
Dim lHigh As Long
Dim varTemp As Variant
Dim varListSeparator As Variant

lLow = lFirst
lHigh = lLast
varListSeparator = arySort((lFirst + lLast) / 2)
Do
Do While (arySort(lLow) < varListSeparator)
lLow = lLow + 1
Loop
Do While (arySort(lHigh) > varListSeparator)
lHigh = lHigh - 1
Loop
If (lLow <= lHigh) Then
varTemp = arySort(lLow)
arySort(lLow) = arySort(lHigh)
arySort(lHigh) = varTemp
lLow = lLow + 1
lHigh = lHigh - 1
End If
Loop While (lLow <= lHigh)
If (lFirst < lHigh) Then
Sort_Quick arySort, lFirst, lHigh
End If
If (lLow < lLast) Then
Sort_Quick arySort, lLow, lLast
End If
End Sub
'----------------------------------------------------------------------------------------------
' Quick Sort, uses recursive method on multidimensional array
' ex: Sort_Quick_MultiSingle myArray, LBound(myArray, 2), UBound(myArray, 2), 1, True
'----------------------------------------------------------------------------------------------
Private Sub Sort_Quick_MultiSingle(ByRef arySort As Variant, _
ByVal lFirst As Long, _
ByVal lLast As Long, _
ByVal iPrimeSort As Integer, _
ByVal bAscending As Boolean)
Dim lLow As Long
Dim lHigh As Long
Dim varListSeparator As Variant
Dim aryTemp() As Variant
Dim x As Long

ReDim aryTemp(UBound(arySort, 1))
lLow = lFirst
lHigh = lLast
varListSeparator = arySort(iPrimeSort, (lFirst + lLast) / 2)
Do
If bAscending = True Then
Do While (arySort(iPrimeSort, lLow) < varListSeparator)
lLow = lLow + 1
Loop
Do While (arySort(iPrimeSort, lHigh) > varListSeparator)
lHigh = lHigh - 1
Loop
Else
Do While (arySort(iPrimeSort, lLow) > varListSeparator)
lLow = lLow + 1
Loop
Do While (arySort(iPrimeSort, lHigh) < varListSeparator)
lHigh = lHigh - 1
Loop
End If
If (lLow <= lHigh) Then
For x = LBound(arySort, 1) To UBound(arySort, 1)
aryTemp(x) = arySort(x, lLow)
Next
For x = LBound(arySort, 1) To UBound(arySort, 1)
arySort(x, lLow) = arySort(x, lHigh)
Next
For x = LBound(arySort, 1) To UBound(arySort, 1)
arySort(x, lHigh) = aryTemp(x)
Next
lLow = lLow + 1
lHigh = lHigh - 1
End If
Loop While (lLow <= lHigh)
If (lFirst < lHigh) Then
Sort_Quick_MultiSingle arySort, lFirst, lHigh, iPrimeSort, bAscending
End If
If (lLow < lLast) Then
Sort_Quick_MultiSingle arySort, lLow, lLast, iPrimeSort, bAscending
End If
End Sub
'----------------------------------------------------------------------------------------------
' Multidimensional Array sort on 2 dimensions
'----------------------------------------------------------------------------------------------
Private Sub Sort_Quick_MultiTwo(ByRef arySort As Variant, _
ByVal lFirst As Long, _
ByVal lLast As Long, _
ByVal iPrimeSort As Integer, _
ByVal iSecSort As Integer, _
ByVal bAscending As Boolean)
Dim lLow As Long
Dim lHigh As Long
Dim varListSeparator1 As Variant
Dim varListSeparator2 As Variant
Dim x As Long
Dim aryTemp() As Variant

ReDim aryTemp(UBound(arySort, 1))
lLow = lFirst
lHigh = lLast
varListSeparator1 = arySort(iPrimeSort, (lFirst + lLast) / 2)
varListSeparator2 = arySort(iSecSort, (lFirst + lLast) / 2)
Do
If bAscending = True Then
Do While (arySort(iPrimeSort, lLow) < varListSeparator1) Or _
((arySort(iPrimeSort, lLow) = varListSeparator1) And _
(arySort(iSecSort, lLow) < varListSeparator2))
lLow = lLow + 1
Loop
Do While (arySort(iPrimeSort, lHigh) > varListSeparator1) Or _
((arySort(iPrimeSort, lHigh) = varListSeparator1) And _
(arySort(iSecSort, lHigh) > varListSeparator2))
lHigh = lHigh - 1
Loop
Else
Do While (arySort(iPrimeSort, lLow) > varListSeparator1) Or _
((arySort(iPrimeSort, lLow) = varListSeparator1) And _
(arySort(iSecSort, lLow) > varListSeparator2))
lLow = lLow + 1
Loop
Do While (arySort(iPrimeSort, lHigh) < varListSeparator1) Or _
((arySort(iPrimeSort, lHigh) = varListSeparator1) And _
(arySort(iSecSort, lHigh) < varListSeparator2))
lHigh = lHigh - 1
Loop
End If
If (lLow <= lHigh) Then
For x = LBound(arySort, 1) To UBound(arySort, 1)
aryTemp(x) = arySort(x, lLow)
Next
For x = LBound(arySort, 1) To UBound(arySort, 1)
arySort(x, lLow) = arySort(x, lHigh)
Next
For x = LBound(arySort, 1) To UBound(arySort, 1)
arySort(x, lHigh) = aryTemp(x)
Next
lLow = lLow + 1
lHigh = lHigh - 1
End If
Loop While (lLow <= lHigh)
If (lFirst < lHigh) Then
Sort_Quick_MultiTwo arySort, lFirst, lHigh, iPrimeSort, iSecSort, bAscending
End If
If (lLow < lLast) Then
Sort_Quick_MultiTwo arySort, lLow, lLast, iPrimeSort, iSecSort, bAscending
End If
End Sub
'----------------------------------------------------------------------------------------------
'sample array sortable by the above function
'----------------------------------------------------------------------------------------------
Private Function fSampleArray_Simple() As Variant
Dim arySample(5) As Variant
arySample(0) = "James"
arySample(1) = "Mary"
arySample(2) = "Tom"
arySample(3) = "Beth"
arySample(4) = "Bob"
arySample(5) = "Al"

fSampleArray_Simple = arySample
End Function
'----------------------------------------------------------------------------------------------
'another sample array, which is sort-able with the above functions
'----------------------------------------------------------------------------------------------
Private Function fSampleArray_MultiSingle() As Variant
Dim arySample(1, 5) As Variant

arySample(0, 0) = "James"
arySample(1, 0) = "1"

arySample(0, 1) = "Mary"
arySample(1, 1) = "3"

arySample(0, 2) = "Tom"
arySample(1, 2) = "5"

arySample(0, 3) = "Beth"
arySample(1, 3) = "2"

arySample(0, 4) = "Bob"
arySample(1, 4) = "4"

arySample(0, 5) = "Al"
arySample(1, 5) = "6"

fSampleArray_MultiSingle = arySample
End Function


4. Of course, none of this really answers your question, although I thought someone else looking for sorting might find the generic array sorting info useful. It certainly took me awhile to find some code and then cobble it together in a more generic way.

I think you've got a perfectly acceptable "kluge" -- alpha sorting is always going to put "nothing" in front of "something" so your solution is to temporarily put "something" you know will be "below" the rest of your "somethings."

As another flavor, I would probably lean towards not loading empty stuff into my array.

'Toggle it back and forth, just for kicks
Sub SortTable2(Optional bTopToBottom As Boolean = True)
Dim oTbl As Table
Dim oCell As Cell
Dim aryData() As String
Dim i As Integer
Dim r As Integer
Dim c As Integer

'initialize our array with no elements
ReDim aryData(i)

'set the table we're in
Set oTbl = Selection.Tables(1)

'load our array of data, but skip anything which is blank
For Each oCell In oTbl.Range.Cells
If Left(oCell.Range, Len(oCell.Range) - 2) <> "" Then
ReDim Preserve aryData(i)
aryData(i) = Left(oCell.Range, Len(oCell.Range) - 2)
i = i + 1
End If
Next

'now sort our array (using my functions above, although WordBasic.SortArray can work too
SortThisArray aryData, QuickSort

'delete the text out of our table
oTbl.Range.Delete
'and reset our array element counter
i = 0

'and now fill the table back up...

'if we're doing top to bottom...
'*NOTE* this will break in any table which has merged cells and/or columns.
'How it breaks is a big question mark, depending on the table's "history" (there be MS bugs here)
If bTopToBottom Then
For c = 1 To oTbl.Columns.Count
For r = 1 To oTbl.Rows.Count
oTbl.Cell(r, c).Range.Text = aryData(i)
'if it's the last element, we're done
If i = UBound(aryData) Then
GoTo l_exit
'otherwise, continue
Else
i = i + 1
End If
Next
Next

'if we're doing left to right, can simply use the same cells collection
'bonus is: this doesn't break when you have merged cells, although
'the results could be wacky, depending on how stuff has been merged
Else
For Each oCell In oTbl.Range.Cells
oCell.Range = aryData(i)
'if it's the last element, we're done
If i = UBound(aryData) Then
GoTo l_exit
'otherwise, continue
Else
i = i + 1
End If
Next

End If
l_exit:
End Sub

[gmaxey]

Hey Jason. Good to see you here. I was just coming back to post my solution and saw your reply. I'll study it.

For the table sort, I'm only looking at a few short entries so I can probably adapt this bit of test code:

Option Explicit
Sub ScratchMacro()
'A quick macro scratch pad created by Greg Maxey
Dim arrS(15) As String
Dim i As Long
arrS(0) = "A"
arrS(1) = "B"
arrS(2) = "C"
arrS(3) = ""
arrS(4) = "D"
arrS(5) = ""
arrS(6) = "Z"
arrS(7) = ""
arrS(8) = "Q"
arrS(9) = ""
arrS(10) = "TC"
arrS(11) = ""
arrS(12) = "Y"
arrS(13) = ""
arrS(14) = "R"
arrS(15) = ""
WordBasic.SortArray arrS
MakeNullStringsLast arrS
For i = 0 To UBound(arrS)
Debug.Print arrS(i)
Next i
End Sub
Sub MakeNullStringsLast(vArrIn As Variant)
Dim i As Long
Dim lngFirstUsedIndex As Long
Dim lngReIndex As Long
'Find first used index.
For i = 0 To UBound(vArrIn)
If Not vArrIn(i) = vbNullString Then
lngFirstUsedIndex = i
Exit For
End If
Next i
lngReIndex = lngFirstUsedIndex
For i = 0 To UBound(vArrIn)
If vArrIn(i) = vbNullString Then
'Take the first used index (now re-index) and put it in this empty one
vArrIn(i) = vArrIn(lngReIndex)
'Put the empty one in the spot vacated
vArrIn(lngReIndex) = vbNullString
'Uptick re-index
lngReIndex = lngReIndex + 1
If lngReIndex > UBound(vArrIn) Then
Exit For
End If
End If
Next i
End Sub

[Frosty]

Good to see you too. Have been swamped and haven't been able to check in much lately.

I see what you're doing. I think Redim Preserve is the way to go though. If you don't fill up your array with empty strings in the first place, you don't have to worry about dealing with them at all. You just have to escape out of your loops when you run out of data.

[fumei]

Greg, can you post a file with an example of the table? I am having trouble picturing it.