Sort Outline Numbers

[gmaxey]

I don't know if it is possible, (impossible with my skill set) but I am trying to find a way of sorting and ordering a mixed list of outline level numbers:

For example if I had:

1.1
1.21
1.3
1.2

The result should be:

1.1
1.2
1.3
1.21

Here is my attempt. I know that my problem is in the bubblesort, but I just don't know how or if this can be fixed and done.

Thanks.


Option Explicit
Sub Test()
Dim strNums As String
Dim arrNums() As String
Dim i As Long
strNums = "1,1.1,1.21,1.3,1.3,1.31.1,1.31,1.2"
arrNums = ValidateStoreSortSiftOutDups(strNums)
For i = 0 To UBound(arrNums)
Debug.Print arrNums(i)
Next i
'Desired result:
'1, 1.1, 1.2, 1.3. 1.21, 1.31, 1.31.1
End Sub
Function ValidateStoreSortSiftOutDups(ByRef strPassed) As String()
Dim arrStrNums() As String
Dim lngIndex As Long, lngCount As Long
Dim arrNums() As String
Dim oDict As Object
Dim varItems As Variant
'Store string of values passed in an array string using Split function.
arrStrNums = Split(strPassed, ",")
'Remove duplicates using a scripting dictionary.
Set oDict = CreateObject("Scripting.Dictionary")
For lngIndex = 0 To UBound(arrStrNums)
If Not oDict.Exists(arrStrNums(lngIndex)) Then
oDict.Add arrStrNums(lngIndex), arrStrNums(lngIndex)
End If
Next lngIndex

'Load unique items into an array of longs.
lngCount = oDict.Count - 1
varItems = oDict.Items
ReDim arrNums(lngCount)
For lngIndex = 0 To lngCount
arrNums(lngIndex) = varItems(lngIndex)
Next lngIndex
On Error GoTo 0
'Sort the unique long values.
fcnBubbleSort arrNums
'Output to called procedure.
ValidateStoreSortSiftOutDups = arrNums
lbl_Exit:
Set oDict = Nothing
Exit Function
End Function
Function fcnBubbleSort(arrPassed)
Dim varTemp As Variant
Dim lngIndex As Long, lngNext As Long
For lngIndex = LBound(arrPassed) To UBound(arrPassed)
For lngNext = lngIndex + 1 To UBound(arrPassed)
If arrPassed(lngIndex) > arrPassed(lngNext) Then
varTemp = arrPassed(lngNext)
arrPassed(lngNext) = arrPassed(lngIndex)
arrPassed(lngIndex) = varTemp
End If
Next lngNext
Next lngIndex
fcnBubbleSort = arrPassed
lbl_Exit:
Exit Function
End Function

[macropod]

Hi Greg,

I'd be inclined to make life easier for myself by padding the numbers with leading 0s before sorting, then removing them afterwards...

Sub Test()
Dim strNums As String, strTmp As String, strNum As String
Dim i As Long, j As Long, StrArry()
strNums = "1, 1.1, 1.21, 1.3, 1.3, 1.31.1, 1.31, 1.2"
For i = 0 To UBound(Split(strNums, ","))
strNum = ""
For j = 0 To UBound(Split(Split(strNums, ",")(i), "."))
strNum = strNum & Format(Split(Split(strNums, ",")(i), ".")(j), "00 ")
Next j
ReDim Preserve StrArry(i)
StrArry(i) = Replace(Trim(strNum), " ", ".") & " "
Next i
Call BubbleSort(StrArry, True)
For i = 0 To UBound(StrArry)
strNum = ""
For j = 0 To UBound(Split(StrArry(i), "."))
strNum = strNum & Format(Split(StrArry(i), ".")(j), "0 ")
Next j
strTmp = strTmp & Replace(Trim(strNum), " ", ".") & " "
Next i
strTmp = Replace(Trim(strTmp), " ", ", ")
MsgBox strNums & vbCr & strTmp
End Sub

Sub BubbleSort(ToSort As Variant, Optional SortAscending As Boolean = True)
Dim AnyChanges As Boolean, BubbleSort As Long, SwapFH As Variant
Do
AnyChanges = False
For BubbleSort = LBound(ToSort) To UBound(ToSort) - 1
If (ToSort(BubbleSort) > ToSort(BubbleSort + 1) And SortAscending) _
Or (ToSort(BubbleSort) < ToSort(BubbleSort + 1) And Not SortAscending) Then
' These two need to be swapped
SwapFH = ToSort(BubbleSort)
ToSort(BubbleSort) = ToSort(BubbleSort + 1)
ToSort(BubbleSort + 1) = SwapFH
AnyChanges = True
End If
Next BubbleSort
Loop Until Not AnyChanges
End Sub

[gmaxey]

Paul,

And I thought my skull was already cracked :-). How do you keep track of all the Split(Split) ;-)

No really. Very helpful thank you. I've of course groomed the code to my style and also ran it through the function to eliminate duplicates.

Option Explicit
Sub Test()
Dim strNums As String, strTmp As String, strNum As String
Dim i As Long, j As Long
Dim arrScrubbed() As String, arrStrNums()
'Define the string.
strNums = "1, 1.1, 1.21, 1.3, 1.3, 1.31.1, 1.31, 1.2"
'Pass to function to remove duplicates.
arrScrubbed = fcnScrubDups(strNums)
For i = 0 To UBound(arrScrubbed) 'UBound(Split(strNums, ","))
strNum = ""
For j = 0 To UBound(Split(arrScrubbed(i), "."))
strNum = strNum & Format(Split(arrScrubbed(i), ".")(j), "00 ")
Next j
ReDim Preserve arrStrNums(i)
arrStrNums(i) = Replace(Trim(strNum), " ", ".") & " "
Next i

Call BubbleSort(arrStrNums, True)
For i = 0 To UBound(arrStrNums)
strNum = ""
For j = 0 To UBound(Split(arrStrNums(i), "."))
strNum = strNum & Format(Split(arrStrNums(i), ".")(j), "0 ")
Next j
strTmp = strTmp & Replace(Trim(strNum), " ", ".") & " "
Next i
'MsgBox strNums & vbCr & Replace(Trim(strTmp), " ", ", ")
MsgBox Replace(Trim(strTmp), " ", ", ")
End Sub
Function fcnScrubDups(ByRef strPassed) As String()
Dim arrStrNums() As String
Dim lngIndex As Long
Dim oDict As Object
Dim varItems As Variant
'Store string of values passed in an array string using Split function.
arrStrNums = Split(strPassed, ",")
'Purge duplicates using a scripting dictionary.
Set oDict = CreateObject("Scripting.Dictionary")
For lngIndex = 0 To UBound(arrStrNums)
If Not oDict.Exists(arrStrNums(lngIndex)) Then oDict.Add arrStrNums(lngIndex), arrStrNums(lngIndex)
Next lngIndex
'Load unique dictionary items into an array.
varItems = oDict.Items
ReDim arrStrNums(oDict.Count - 1)
For lngIndex = 0 To oDict.Count - 1
arrStrNums(lngIndex) = varItems(lngIndex)
Next lngIndex
fcnScrubDups = arrStrNums
lbl_Exit:
Set oDict = Nothing
Exit Function
End Function
Sub BubbleSort(varSortItems As Variant, Optional bAscending As Boolean = True)
Dim bChanges As Boolean, lngIndex As Long, SwapFH As Variant
Do
bChanges = False
For lngIndex = LBound(varSortItems) To UBound(varSortItems) - 1
If (varSortItems(lngIndex) > varSortItems(lngIndex + 1) And bAscending) _
Or (varSortItems(lngIndex) < varSortItems(lngIndex + 1) And Not bAscending) Then
'These two need to be swapped
SwapFH = varSortItems(lngIndex)
varSortItems(lngIndex) = varSortItems(lngIndex + 1)
varSortItems(lngIndex + 1) = SwapFH
bChanges = True
End If
Next lngIndex
Loop Until Not bChanges
End Sub


The next challenge is to see if I can figure out how to parse the output string
to produce a concanate string like we worked on before but a little different.

Suppse the output was 1,1.2,1.3,1.4,1.6,1.7.1, 1.7.2, 1.7.3,1.7.4

I need to produce an output string where any number that should be masked in a concanated string is replaced with "X" as follows:

1,1.2,X,1.4,1.6,1.7.1,X,X,1.7.4

Back to to the task. Thanks.

[macropod]

There's an easier way to eliminate the duplicates:
Sub Test()
Dim strNums As String, strTmp As String, strNum As String
Dim i As Long, j As Long, StrArry()
strNums = "1, 1.1, 1.21, 1.3, 1.3, 1.31.1, 1.31, 1.2"
For i = 0 To UBound(Split(strNums, ","))
strNum = ""
strTmp = Split(strNums, ",")(i)
For j = 0 To UBound(Split(strTmp, "."))
strNum = strNum & Format(Split(strTmp, ".")(j), "00 ")
Next j
ReDim Preserve StrArry(i)
StrArry(i) = Replace(Trim(strNum), " ", ".") & " "
Next i
strTmp = ""
Call BubbleSort(StrArry, True)
For i = 0 To UBound(StrArry)
strNum = ""
If i > 0 Then
If StrArry(i) <> StrArry(i - 1) Then
For j = 0 To UBound(Split(StrArry(i), "."))
strNum = strNum & Format(Split(StrArry(i), ".")(j), "0 ")
Next j
strTmp = strTmp & Replace(Trim(strNum), " ", ".") & " "
End If
Else
For j = 0 To UBound(Split(StrArry(i), "."))
strNum = strNum & Format(Split(StrArry(i), ".")(j), "0 ")
Next j
strTmp = strTmp & Replace(Trim(strNum), " ", ".") & " "
End If
Next i
strTmp = Replace(Trim(strTmp), " ", ", ")
MsgBox strNums & vbCr & strTmp
End Sub
PS: Just for your skull's sake I've eliminated the nested splits (not really - they're still there but they're not expressed in quite the same way).

[gmaxey]

Hi Paul,

Yes, that is simpler. Thanks.

[macropod]

Try:
Sub Test()
Dim StrIn As String, StrTmp1 As String, StrTmp2 As String, StrTmp3 As String, StrTmp4 As String
Dim i As Long, j As Long, k As Long, StrArry()
StrIn = "1, 1.1, 1.21, 1.3, 1.3, 1.31.1, 1.31, 1.2"
For i = 0 To UBound(Split(StrIn, ","))
StrTmp1 = Split(StrIn, ",")(i)
StrTmp2 = ""
For j = 0 To UBound(Split(StrTmp1, "."))
StrTmp2 = StrTmp2 & Format(Split(StrTmp1, ".")(j), "00")
Next j
ReDim Preserve StrArry(i)
StrArry(i) = StrTmp2
Next i
Call BubbleSort(StrArry, True)
StrTmp1 = StrArry(0)
For i = 1 To UBound(StrArry)
If StrArry(i) <> StrArry(i - 1) Then StrTmp1 = StrTmp1 & " " & StrArry(i)
Next i
StrTmp1 = Replace(ParseNumSeq(Replace(Trim(StrTmp1), " ", ",")), " ", "")
For i = 0 To UBound(Split(StrTmp1, ","))
ReDim Preserve StrArry(i)
StrArry(i) = Split(StrTmp1, ",")(i)
Next
For i = 0 To UBound(StrArry)
StrTmp1 = StrArry(i)
StrTmp2 = ""
For j = 0 To UBound(Split(StrTmp1, "-"))
StrTmp3 = Split(StrTmp1, "-")(j)
StrTmp4 = ""
For k = 2 To Len(StrTmp3) Step 2
StrTmp4 = StrTmp4 & Format(Mid(StrTmp3, k - 1, 2), "0 ")
Next
StrTmp2 = StrTmp2 & Replace(Trim(StrTmp4), " ", ".") & " "
Next j
StrArry(i) = Replace(Trim(StrTmp2), " ", "-")
Next i
StrTmp1 = ""
For i = 0 To UBound(StrArry)
StrTmp1 = StrTmp1 & StrArry(i) & " "
Next
StrTmp1 = Replace(Trim(StrTmp1), " ", ", ")
MsgBox StrIn & vbCr & StrTmp1
End Sub
Sub BubbleSort(ToSort As Variant, Optional SortAscending As Boolean = True)
Dim AnyChanges As Boolean, BubbleSort As Long, SwapFH As Variant
Do
AnyChanges = False
For BubbleSort = LBound(ToSort) To UBound(ToSort) - 1
If (ToSort(BubbleSort) > ToSort(BubbleSort + 1) And SortAscending) _
Or (ToSort(BubbleSort) < ToSort(BubbleSort + 1) And Not SortAscending) Then
' These two need to be swapped
SwapFH = ToSort(BubbleSort)
ToSort(BubbleSort) = ToSort(BubbleSort + 1)
ToSort(BubbleSort + 1) = SwapFH
AnyChanges = True
End If
Next BubbleSort
Loop Until Not AnyChanges
End Sub
Function ParseNumSeq(StrTmp3 As String, Optional StrEnd As String)
'This function converts multiple sequences of 3 or more consecutive numbers in a
' list to a string consisting of the first & last numbers separated by a hyphen.
Dim ArrTmp(), i As Integer, j As Integer, k As Integer
ReDim ArrTmp(UBound(Split(StrTmp3, ",")))
For i = 0 To UBound(Split(StrTmp3, ","))
ArrTmp(i) = Split(StrTmp3, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To UBound(ArrTmp)
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = ""
k = k + 1
Next
i = j - 2
End If
Next
StrTmp3 = Join(ArrTmp, ",")
StrTmp3 = Replace(Replace(Replace(StrTmp3, ",,", " "), ", ", " "), " ,", " ")
While InStr(StrTmp3, " ")
StrTmp3 = Replace(StrTmp3, " ", " ")
Wend
StrTmp3 = Replace(Replace(StrTmp3, " ", "-"), ",", ", ")
If StrEnd <> "" Then
i = InStrRev(StrTmp3, ",")
If i > 0 Then
StrTmp3 = Left(StrTmp3, i - 1) & Replace(StrTmp3, ",", " " & Trim(StrEnd), i)
End If
End If
ParseNumSeq = StrTmp3
End Function

[gmaxey]

Paul, That is moving in the right direction but I am just too whipped right now to try to resolve it further.

The objective is to return a string where any number that "should" be masked in a truncated string appears in the return as an "X"

StrIn = "1, 1.1, 1.21, 1.22, 1.23, 1.24, 1.25, 1.3, 1.3, 1.31.1, 1.31, 1.2"
'Return needed: 1,1.1,X,1.3,1.21,X,X,X,1.25,1.31,1.31.1"

[macropod]

In that case, you might use the above code with the previous version of the parser that (incorrectly) output the consecutive '-' characters and, for the final output, simply replace those with the mask characters.

[gmaxey]

Paul,

I couldn't make that work, but I think (limited testing) that I've managed to put together some of your code with my cobbling to achieve the desired result:

Sub ConconateOutlineNumbers()
Dim strInput As String, strTemp1 As String, strTemp2 As String, strTemp3 As String, strTemp4 As String
Dim i As Long, j As Long, k As Long, lngStart As Long, lngEnd As Long
Dim arrInput() As String, arrNumberStrings() As String, arrJoined() As String

strInput = "1, 1.1, 1.21, 1.22, 1.23, 1.24, 1.25, 1 .3, 1.3, 1.4, 1.31.1, 1.31.2,1.31.3, 1.31.4, 1.2"
arrInput = Split(strInput, ",")
For i = 0 To UBound(arrInput)
strTemp1 = arrInput(i)
'Prefix each string number (first number and each number following a ".". This aids in sorting.
strTemp2 = ""
For j = 0 To UBound(Split(strTemp1, "."))
strTemp2 = strTemp2 & Format(Split(strTemp1, ".")(j), "00")
Next j
ReDim Preserve arrNumberStrings(i)
arrNumberStrings(i) = strTemp2
Next i
'String in array now look like 01,0101,0121 etc.
'Sort the number strings.
Call BubbleSort(arrNumberStrings, True)

strTemp1 = arrNumberStrings(0)
'Remove duplicates.
For i = 1 To UBound(arrNumberStrings)
If arrNumberStrings(i) <> arrNumberStrings(i - 1) Then strTemp1 = strTemp1 & " " & arrNumberStrings(i)
Next i
'Parse the string. This returns a concanated string e.g., 1, 1.1-1.4, etc.
strTemp1 = Replace(ParseNumSeq(Replace(Trim(strTemp1), " ", ",")), " ", "")
'Remove 0 placeholders and replace decimals.
For i = 0 To UBound(Split(strTemp1, ","))
ReDim Preserve arrNumberStrings(i)
arrNumberStrings(i) = Split(strTemp1, ",")(i)
Next
For i = 0 To UBound(arrNumberStrings)
strTemp1 = arrNumberStrings(i)
strTemp2 = ""
For j = 0 To UBound(Split(strTemp1, "-"))
strTemp3 = Split(strTemp1, "-")(j)
strTemp4 = ""
For k = 2 To Len(strTemp3) Step 2
strTemp4 = strTemp4 & Format(Mid(strTemp3, k - 1, 2), "0 ")
Next
strTemp2 = strTemp2 & Replace(Trim(strTemp4), " ", ".") & " "
Next j
arrNumberStrings(i) = Replace(Trim(strTemp2), " ", "-")
Next i
strTemp1 = ""
For i = 0 To UBound(arrNumberStrings)
strTemp1 = strTemp1 & arrNumberStrings(i) & " "
Next
strTemp1 = Replace(Trim(strTemp1), " ", ", ")

'Returns concanated list.
Debug.Print strTemp1

'Now convert "-" to "Xs"
Erase arrNumberStrings
arrNumberStrings = Split(strTemp1, ",")
strTemp1 = ""
For i = 0 To UBound(arrNumberStrings)
If InStr(arrNumberStrings(i), "-") = 0 Then
strTemp1 = strTemp1 & arrNumberStrings(i) & ","
Else
arrJoined = Split(arrNumberStrings(i), "-")
strTemp1 = strTemp1 & arrJoined(0) & ","
lngStart = VBA.Right(arrJoined(0), Len(arrJoined(0)) - InStrRev(arrJoined(0), "."))
lngEnd = VBA.Right(arrJoined(1), Len(arrJoined(1)) - InStrRev(arrJoined(1), "."))
For j = lngStart + 1 To lngEnd - 1
strTemp1 = strTemp1 & "X,"
Next j
strTemp1 = strTemp1 & arrJoined(1) & ","
End If
Next i
MsgBox strTemp1
End Sub


Function ParseNumSeq(strNums As String, Optional strFinalSep As String) As String
'Converts multiple sequences of 3 or more consecutive numbers in a list to a string
'consisting of the first & last numbers separated by a hyphen.
Dim ArrTmp() As String, strValid As String
Dim lngIndex As Long, lngAdv As Long, lngOffset As Long
'Create array of numbers passed.
ArrTmp = Split(Replace(strNums, " ", ""), ",")
'Validate string passed.
strValid = Join(ArrTmp, "")
'Does string consist of whole numbers only?
If InStr(strValid, ".") > 0 Or InStr(strValid, "$") > 0 Or Not IsNumeric(strValid) Then
ParseNumSeq = "Invalid string. The string passed must be whole numbers only."
Exit Function
End If
'Are whole numbers increasing in sequence?
For lngIndex = 0 To UBound(ArrTmp) - 1
If CLng(ArrTmp(lngIndex)) >= CLng(ArrTmp(lngIndex + 1)) Then
ParseNumSeq = "Invalid string. The string passed must be whole numbers increasing in sequence."
Exit Function
End If
Next lngIndex
'Parse each number except the last number.
For lngIndex = 0 To UBound(ArrTmp) - 1
lngOffset = 2
For lngAdv = lngIndex + 2 To UBound(ArrTmp)
'Does the offset number element match the next expected number in a continous sequence?
If ArrTmp(lngIndex) + lngOffset <> ArrTmp(lngAdv) Then
Exit For
Else
ArrTmp(lngAdv - 1) = ""
lngOffset = lngOffset + 1
End If
Next
'Revise indexing.
lngIndex = lngAdv - 2
Next
'Debug.Print strNums
'Format the output string.
strNums = ""
For lngIndex = 0 To UBound(ArrTmp)
If ArrTmp(lngIndex) <> "" Then
'Does this number end a conconated number sequence?
If Right(strNums, 1) = "-" Then
strNums = strNums & ArrTmp(lngIndex)
Else
On Error Resume Next
If ArrTmp(lngIndex) - 1 <> ArrTmp(lngIndex - 1) Then
'Is this the first pass? Yes, then expect error due to scope conflict.
If Err.Number <> 0 Then
'Define first number.
strNums = strNums & ArrTmp(lngIndex)
Else
'Start new sequence.
strNums = strNums & ", " & ArrTmp(lngIndex)
End If
Else
'Two numbers in sequence. List both.
strNums = strNums & ", " & ArrTmp(lngIndex)
End If
End If
Else
If Not Right(strNums, 1) = "-" Then
'Flag in conconated number sequence.
strNums = strNums & "-"
End If
End If
Next lngIndex
'Format optional final separator.
If strFinalSep <> "" Then
lngIndex = InStrRev(strNums, ",")
If lngIndex > 0 Then
strNums = Left(strNums, lngIndex - 1) & Replace(strNums, ",", " " & Trim(strFinalSep), lngIndex)
End If
End If
ParseNumSeq = strNums
End Function

Sub BubbleSort(varItemsToSort As Variant, Optional bAscending As Boolean = True)
Dim bChanges As Boolean, lngIndex As Long, varSwap As Variant

Do
bChanges = False
For lngIndex = LBound(varItemsToSort) To UBound(varItemsToSort) - 1
If (varItemsToSort(lngIndex) > varItemsToSort(lngIndex + 1) And bAscending) _
Or (varItemsToSort(lngIndex) < varItemsToSort(lngIndex + 1) And Not bAscending) Then
'These two need to be swapped.
varSwap = varItemsToSort(lngIndex)
varItemsToSort(lngIndex) = varItemsToSort(lngIndex + 1)
varItemsToSort(lngIndex + 1) = varSwap
bChanges = True
End If
Next lngIndex
Loop Until Not bChanges
End Sub


I'm sure there is a better way, but it seems to work.

[macropod]

Hi Greg,

Try:
Sub Test()
Dim StrIn As String, StrTmp1 As String, StrTmp2 As String, StrTmp3 As String, StrTmp4 As String
Dim i As Long, j As Long, k As Long, StrArry()
StrIn = "1, 1.1, 1.21, 1.3, 1.4, 1.31.1, 1.31, 1.2, 1.5"
For i = 0 To UBound(Split(StrIn, ","))
StrTmp1 = Split(StrIn, ",")(i)
StrTmp2 = ""
For j = 0 To UBound(Split(StrTmp1, "."))
StrTmp2 = StrTmp2 & Format(Split(StrTmp1, ".")(j), "00")
Next j
ReDim Preserve StrArry(i)
StrArry(i) = StrTmp2
Next i
Call BubbleSort(StrArry, True)
StrTmp1 = StrArry(0)
For i = 1 To UBound(StrArry)
If StrArry(i) <> StrArry(i - 1) Then StrTmp1 = StrTmp1 & " " & StrArry(i)
Next i
StrTmp1 = Replace(ParseNumSeq(Replace(Trim(StrTmp1), " ", ",")), " ", "")
For i = 0 To UBound(Split(StrTmp1, ","))
ReDim Preserve StrArry(i)
StrArry(i) = Split(StrTmp1, ",")(i)
Next
For i = 0 To UBound(StrArry)
StrTmp1 = StrArry(i)
StrTmp2 = ""
For j = 0 To UBound(Split(StrTmp1, "-"))
StrTmp3 = Split(StrTmp1, "-")(j)
StrTmp4 = ""
If IsNumeric(StrTmp3) Then
For k = 2 To Len(StrTmp3) Step 2
StrTmp4 = StrTmp4 & Format(Mid(StrTmp3, k - 1, 2), "0 ")
Next
Else
StrTmp4 = StrTmp3
End If
StrTmp2 = StrTmp2 & Replace(Trim(StrTmp4), " ", ".") & " "
Next j
StrArry(i) = Replace(Trim(StrTmp2), " ", "-")
Next i
StrTmp1 = ""
For i = 0 To UBound(StrArry)
StrTmp1 = StrTmp1 & StrArry(i) & " "
Next
StrTmp1 = Replace(Trim(StrTmp1), " ", ", ")
MsgBox StrIn & vbCr & StrTmp1
End Sub
Sub BubbleSort(ToSort As Variant, Optional SortAscending As Boolean = True)
Dim AnyChanges As Boolean, BubbleSort As Long, SwapFH As Variant
Do
AnyChanges = False
For BubbleSort = LBound(ToSort) To UBound(ToSort) - 1
If (ToSort(BubbleSort) > ToSort(BubbleSort + 1) And SortAscending) _
Or (ToSort(BubbleSort) < ToSort(BubbleSort + 1) And Not SortAscending) Then
' These two need to be swapped
SwapFH = ToSort(BubbleSort)
ToSort(BubbleSort) = ToSort(BubbleSort + 1)
ToSort(BubbleSort + 1) = SwapFH
AnyChanges = True
End If
Next BubbleSort
Loop Until Not AnyChanges
End Sub
Function ParseNumSeq(StrTmp As String, Optional StrEnd As String)
'This function converts multiple sequences of 3 or more consecutive numbers in a
' list to a string consisting of the first & last numbers separated by a hyphen.
Dim ArrTmp(), i As Integer, j As Integer, k As Integer
ReDim ArrTmp(UBound(Split(StrTmp, ",")))
For i = 0 To UBound(Split(StrTmp, ","))
ArrTmp(i) = Split(StrTmp, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To UBound(ArrTmp)
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = "X"
k = k + 1
Next
i = j - 2
End If
Next
StrTmp = Join(ArrTmp, ",")
StrTmp = Replace(Replace(Replace(StrTmp, ",,", " "), ", ", " "), " ,", " ")
While InStr(StrTmp, " ")
StrTmp = Replace(StrTmp, " ", " ")
Wend
StrTmp = Replace(Replace(StrTmp, " ", "-"), ",", ", ")
If StrEnd <> "" Then
i = InStrRev(StrTmp, ",")
If i > 0 Then
StrTmp = Left(StrTmp, i - 1) & Replace(StrTmp, ",", " " & Trim(StrEnd), i)
End If
End If
ParseNumSeq = StrTmp
End Function

[gmaxey]

Hi Paul,

So far so good. Same result with lest lines of code. I'll let you know if I find something that causes either method to fall over. Thanks.