Andrew,
Unfortunately we came to the same discovery. Only I thought perhaps that you had discovered something previously that did work :-(
You are also correct about the flaw which Austin had right to start with. I've also beefed up the fcnKillWhiteSpace (which you like to refer to by its more colorful name).
Code:
Option Explicit
Const strSpanDelimiter = "-"
Sub ListExpandSortDeDupCompress()
Dim strNumberList As String
Dim arrMixed() As String
Dim varRawNumbers
Dim arrLongs() As Long
Dim strStart As String, strEnd As String
Dim lngPos As Long
Dim lngIndex As Integer
Dim lngCount As Integer
Dim oDic As Object
Set oDic = CreateObject("Scripting.Dictionary")
strNumberList = fcnKillWhiteSpace(Selection.Text)
arrMixed = Split(strNumberList, ",")
On Error GoTo Err_Handler
For lngIndex = LBound(arrMixed) To UBound(arrMixed)
If InStr(1, arrMixed(lngIndex), strSpanDelimiter) Then
varRawNumbers = Split(arrMixed(lngIndex), strSpanDelimiter)
strStart = varRawNumbers(LBound(varRawNumbers))
strEnd = varRawNumbers(UBound(varRawNumbers))
If fcnIsCountingNumber(strStart) And fcnIsCountingNumber(strEnd) Then
For lngCount = strStart To strEnd
If Not oDic.Exists(lngCount) Then oDic.Add lngCount, lngCount
Next lngCount
Else
Err.Raise vbObjectError + 1
End If
Else
If fcnIsCountingNumber(arrMixed(lngIndex)) Then
If Not oDic.Exists(CLng(arrMixed(lngIndex))) Then oDic.Add CLng(arrMixed(lngIndex)), CLng(arrMixed(lngIndex))
Else
Err.Raise vbObjectError + 1
End If
End If
Next lngIndex
On Error GoTo 0
varRawNumbers = oDic.Items
BubbleSort varRawNumbers
strNumberList = Join(varRawNumbers, ",")
MsgBox (strNumberList)
strNumberList = fcnConcatenateNumbers(varRawNumbers)
strNumberList = Replace(strNumberList, ",", ", ")
Selection.InsertAfter vbCr & strNumberList
lbl_Exit:
Exit Sub
Err_Handler:
If Err.Number = vbObjectError + 1 Then
MsgBox "The selection contains one or more characters that prevent processing." & vbCr + vbCr _
& "The selected text must contain counting numbers (separated by commas or the span " _
& "delimiter """ & strSpanDelimiter & """) only.", _
vbInformation + vbOKOnly, "INVALID CONTENT"
End If
Resume lbl_Exit
End Sub
Sub Test()
MsgBox fcnKillWhiteSpace("A B V")
End Sub
Function fcnKillWhiteSpace(strRaw As String) As String
Dim arrSpaces() As String
Dim lngIndex As Long
Dim strTemp As String
strTemp = strRaw
arrSpaces = Split("9,11,13,32,160,8194,8195,8196,8197", ",")
For lngIndex = 0 To UBound(arrSpaces)
strTemp = Replace(strTemp, ChrW(arrSpaces(lngIndex)), "")
Next lngIndex
fcnKillWhiteSpace = strTemp
lbl_Exit:
Exit Function
End Function
Function fcnIsCountingNumber(strTest) As Boolean
Dim lngTest As Long
fcnIsCountingNumber = False
If IsNumeric(strTest) Then
lngTest = CLng(strTest)
If Len(CStr(lngTest)) = Len(strTest) Then fcnIsCountingNumber = True
End If
lbl_Exit:
Exit Function
End Function
Sub BubbleSort(varPassed)
Dim lngIndex As Long
Dim lngNextIndex As Long
Dim varSwap As Variant
Dim strStart As String, strEnd As String
Dim lngPos As Integer
For lngIndex = LBound(varPassed) To UBound(varPassed) - 1
For lngNextIndex = lngIndex + 1 To UBound(varPassed)
If InStr(1, varPassed(lngNextIndex), "-") Then
lngPos = InStr(1, varPassed(lngNextIndex), "-") + 1
strStart = CInt(Left(varPassed(lngNextIndex), lngPos))
strEnd = CInt(Right(varPassed(lngNextIndex), Len(varPassed(lngNextIndex)) - lngPos))
End If
If IsNumeric(varPassed(lngIndex)) And IsNumeric(varPassed(lngNextIndex)) Then
If Val(varPassed(lngIndex)) > Val(varPassed(lngNextIndex)) Then
varSwap = varPassed(lngIndex)
varPassed(lngIndex) = varPassed(lngNextIndex)
varPassed(lngNextIndex) = varSwap
End If
ElseIf varPassed(lngIndex) > varPassed(lngNextIndex) Then
varSwap = varPassed(lngIndex)
varPassed(lngIndex) = varPassed(lngNextIndex)
varPassed(lngNextIndex) = varSwap
End If
Next lngNextIndex
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Public Function fcnConcatenateNumbers(varNumbers) As String
'varNumbers is a variant array of counting numbers in ascending order.
Dim strTemp As String
Dim lngLastNumberIndex As Long, lngElement As Long, lngIndex As Long
Dim bConsecutive As Boolean
Dim lngConsecutiveSpanStart As Long, lngConsecutiveCount As Long
strTemp = ""
lngLastNumberIndex = UBound(varNumbers)
lngElement = 0
While lngElement <= lngLastNumberIndex
lngConsecutiveSpanStart = lngElement
lngConsecutiveCount = 0
'See if adjacent elements are consecutive.
Do
lngConsecutiveCount = lngConsecutiveCount + 1
If lngElement = lngLastNumberIndex Then
bConsecutive = False
Else
'Is the next number = 1 + the current number?
bConsecutive = (varNumbers(lngElement + 1) = varNumbers(lngElement) + 1)
lngElement = lngElement + 1
End If
Loop While bConsecutive
If lngConsecutiveCount > 2 Then
strTemp = strTemp & "," & Format$(varNumbers(lngConsecutiveSpanStart)) & _
strSpanDelimiter & Format$(varNumbers(lngConsecutiveSpanStart + lngConsecutiveCount - 1))
Else 'output the separate elements
For lngIndex = lngConsecutiveSpanStart To lngConsecutiveSpanStart + lngConsecutiveCount - 1
strTemp = strTemp & "," & Format$(varNumbers(lngIndex))
Next
End If
lngElement = lngConsecutiveSpanStart + lngConsecutiveCount
Wend
fcnConcatenateNumbers = Mid$(strTemp, 2) 'Get rid of first comma!
lbl_Exit:
Exit Function
End Function