Option Explicit

Sub ListExpandSortDeDupCompress()
  Dim strNumberList As String
  Dim arrMixed() As String, iNum As Integer
  Dim oRs  As New ADODB.Recordset
  Dim oDic As Object
  Dim varRawNumbers As Variant

  Set oDic = CreateObject("Scripting.Dictionary")
  
  strNumberList = fcnKillWhiteSpace(Selection.Text)
  arrMixed = Split(strNumberList, ",")
  Set oRs = ConvertToExpandedRecordset(arrMixed)
  
  'Sort the recordset into order and create a dictionary of unique values (in sorted order)
  oRs.Sort = "[FldNum]"
  With oRs
    .MoveLast
    If .RecordCount > 0 Then
      .MoveFirst
      While Not .EOF
        iNum = .Fields("FldNum").Value
        If Not oDic.Exists(iNum) Then oDic.Add iNum, iNum
        .MoveNext
      Wend
    End If
  End With
  
'  varRawNumbers = oDic.Items
'  strNumberList = Join(varRawNumbers, ",")
'  Debug.Print strNumberList
  strNumberList = ConvertDict2CompressedString(oDic)
  Selection.InsertAfter vbCr & strNumberList
End Sub

Private Function ConvertToExpandedRecordset(arrValues() As String) As Recordset
  Dim oRs  As New ADODB.Recordset, arrSpan() As String
  Dim lRec As Long, lCount As Long
  
  oRs.Fields.Append "FldName", adVariant, , adFldMayBeNull
  oRs.Fields.Append "FldNum", adInteger, , adFldMayBeNull
  
  oRs.Open
  For lRec = LBound(arrValues) To UBound(arrValues)
    If InStr(arrValues(lRec), "-") > 0 Then
      arrSpan = Split(arrValues(lRec), "-")
      For lCount = CLng(arrSpan(0)) To CLng(arrSpan(1))
        oRs.AddNew
        oRs("FldName").Value = lCount
        oRs("FldNum").Value = lCount
        oRs.Update
      Next lCount
    Else
      oRs.AddNew
      oRs("FldName").Value = arrValues(lRec)
      oRs("FldNum").Value = CLng(arrValues(lRec))
      oRs.Update
    End If
  Next lRec
  Set ConvertToExpandedRecordset = oRs
End Function

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 ConvertDict2CompressedString(oDic) As String
  Dim v As Variant, bConsecutive As Boolean, sRun As String
  Dim iStartRun As Integer, iEndRun As Integer, sTemp As String
  
  For Each v In oDic.Keys
    If oDic.Exists(v + 1) Then
      If Not bConsecutive Then  'first entry in a run
        iStartRun = v
        bConsecutive = True
        'sRun = iStartRun & "," & v
      ElseIf v - iStartRun = 1 Then 'second entry in a run
        sRun = iStartRun & "," & v
      Else  'run has 3+ entries
        iEndRun = v
        sRun = iStartRun & "-" & v
      End If
    Else
      If Not bConsecutive Then
        sRun = v
        sTemp = sTemp & "," & sRun
      ElseIf v - iStartRun = 1 Then
        sRun = iStartRun & "," & v
        sTemp = sTemp & "," & sRun
      Else
        sTemp = sTemp & "," & iStartRun & "-" & v
      End If
      bConsecutive = False
    End If
  Next
  Debug.Print sTemp
  
  sTemp = Mid(sTemp, 2)
  ConvertDict2CompressedString = Replace(sTemp, ",", ", ")
End Function

Sub Demo()
Dim StrIn As String, StrOut As String, NumArr(), i As Long, j As Long
StrIn = "11, 14, 35-37, 39-41, 49-51, 57-58, 63-64, 66, 68, 73-78, 82-87, " & _
        "96, 114, 123, 17, 20-23, 25, 42, 56, 69-71, 89-91, 124, 17, " & _
        "22-23, 56, 70, 89-91, 124, 20-21, 42, 69, 71, 25, 16, 18-19, 26-29, " & _
        "32, 52, 72, 125, 43, 46, 53, 54, 59-62, 88, 93-94, 92, 116, 121, 122"
StrIn = "," & Replace(ParseNumberString(StrIn, ", ", "-"), " ", "") & ","
i = UBound(Split(StrIn, ","))
Do While UBound(Split(StrIn, ",")) > 1
  StrOut = StrOut & " " & Split(StrIn, ",")(1)
  StrIn = Replace(StrIn, "," & Split(StrIn, ",")(1) & ",", ",")
  StrIn = Replace(StrIn, "," & Split(StrIn, ",")(1) & ",", ",")
Loop
StrIn = Trim(StrOut)
i = UBound(Split(StrIn, " "))
ReDim NumArr(i)
For j = 0 To i
  NumArr(j) = Split(StrIn, " ")(j)
Next
WordBasic.SortArray NumArr()
StrOut = Join(NumArr(), ",")
MsgBox ParseNumSeq(StrOut, "&")
End Sub
 
Function ParseNumberString(StrIn As String, strSS, strGS)
Dim i As Long, j As Long, StrTmp As String, Arr As Variant
Arr = Filter(Split(StrIn, strSS), strGS)
For i = 0 To UBound(Arr)
  StrTmp = ""
  For j = Val(Arr(i)) To Split(Arr(i), strGS)(1)
    StrTmp = StrTmp & strSS & j
  Next
  StrIn = Replace(StrIn, Arr(i), Mid(StrTmp, 2))
Next
ParseNumberString = StrIn
End Function

Function ParseNumSeq(StrNums 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.
' The separator for the last sequence can be set via the StrEnd variable.
Dim ArrTmp(), i As Integer, j As Integer, k As Integer
ReDim ArrTmp(UBound(Split(StrNums, ",")))
For i = 0 To UBound(Split(StrNums, ","))
  ArrTmp(i) = Split(StrNums, ",")(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
StrNums = Join(ArrTmp, ",")
StrNums = Replace(Replace(Replace(StrNums, ",,", " "), ", ", " "), " ,", " ")
While InStr(StrNums, "  ")
  StrNums = Replace(StrNums, "  ", " ")
Wend
StrNums = Replace(Replace(StrNums, " ", "-"), ",", ", ")
If StrEnd <> "" Then
  i = InStrRev(StrNums, ",")
  If i > 0 Then
    StrNums = Left(StrNums, i - 1) & Replace(StrNums, ",", " " & Trim(StrEnd), i)
  End If
End If
ParseNumSeq = StrNums
End Function

For i = 29 To 20 Step -1
  StrIn = Replace(StrIn, "," & i & ",", "," & i + 1 & ",")
Next

For i = 21 To 30
  StrIn = Replace(StrIn, "," & i & ",", "," & i - 1 & ",")
Next