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
Function fcnKillWhiteSpace(strRaw As String) As String
Dim strTemp As String
  strTemp = Replace(strRaw, " ", "")
  strTemp = Replace(strTemp, Chr(160), "")
  strTemp = Replace(strTemp, Chr(13), "")
  strTemp = Replace(strTemp, Chr(11), "")
  strTemp = Replace(strTemp, Chr(9), "")
  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
        strTemp = strTemp & "," & Format$(varNumbers(lngConsecutiveSpanStart))
    End If
    lngElement = lngConsecutiveSpanStart + lngConsecutiveCount
  Wend
  fcnConcatenateNumbers = Mid$(strTemp, 2) 'Get rid of first comma!
lbl_Exit:
  Exit Function
End Function