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