Sub ListExpandSortDeDupCompress()

Dim arrItems() As String
Dim OGList As String
Dim SplitList() As String
Dim FinalArray() As String
Dim LongArray() As Long
Dim Lease1 As String, Lease2 As String, InLease As Integer
Dim pos As Long

OGList = Selection.Text
OGList = Replace(OGList, " ", "")
SplitList = Split(OGList, ",")

  
Dim I As Integer
Dim j As Integer

For I = LBound(SplitList) To UBound(SplitList)
    If InStr(1, SplitList(I), "-") Then
        pos = CInt(InStr(1, SplitList(I), "-") - 1)
        Lease1 = Left(SplitList(I), pos)
        Lease2 = Right(SplitList(I), Len(SplitList(I)) - pos - 1)
        SplitList(I) = Str(Lease1)
        For j = Lease1 + 1 To Lease2
            SplitList(I) = SplitList(I) & "," & Str(j)
        Next j
    End If
Next I
  
  
OGList = Join(SplitList, ",")
OGList = Replace(OGList, " ", "")
'MsgBox (OGList)

SplitList = Split(OGList, ",")
Call BubbleSort(SplitList)
OGList = Join(SplitList, ",")
OGList = Replace(OGList, " ", "")
'MsgBox (OGList)

ReDim FinalArray(1 To 1) As String
For I = LBound(SplitList) To UBound(SplitList)
    If Not IsInArray(SplitList(I), FinalArray) Then
    FinalArray(UBound(FinalArray)) = SplitList(I)
    ReDim Preserve FinalArray(1 To UBound(FinalArray) + 1) As String
    End If
Next I

OGList = Join(FinalArray, ",")
OGList = Replace(OGList, " ", "")
MsgBox (OGList)
SplitList = Split(OGList, ",")


LongArray = StrToLng(FinalArray)
OGList = RangeExtraction(LongArray)


'OGList = Join(FinalArray, ",")
'OGList = Replace(OGList, " ", "")
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeText Text:=OGList


End Sub
Public Function StrToLng(Str() As String) As Long()
  Dim I As Long
  Dim lng() As Long
  
  ReDim lng(LBound(Str) To UBound(Str))
  'Any Errors will result in a Zero in that element
  On Error Resume Next
  For I = LBound(Str) To UBound(Str)
    'Val() is more forgiving
    lng(I) = Val(Str(I))
  Next I
  
  'return the resulting array
  StrToLng = lng
  
  'free up memory used by dynamic array
  Erase lng
End Function
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = UBound(Filter(arr, stringToBeFound)) > -1
End Function

Sub BubbleSort(arr)
    Dim I As Integer
    Dim j As Integer
    Dim itm As Variant
    Dim Lease1 As String, Lease2 As String, InLease As Integer
    Dim pos As Integer
    
    
    
    
    For I = LBound(arr) To UBound(arr) - 1
        For j = I + 1 To UBound(arr)
            If InStr(1, arr(j), "-") Then
            pos = InStr(1, arr(j), "-") + 1
            Lease1 = CInt(Left(arr(j), pos))
            Lease2 = CInt(Right(arr(j), Len(arr(j)) - pos))
            End If
            
            If IsNumeric(arr(I)) And IsNumeric(arr(j)) Then
                If Val(arr(I)) > Val(arr(j)) Then
                    itm = arr(I)
                    arr(I) = arr(j)
                    arr(j) = itm
                End If
            ElseIf arr(I) > arr(j) Then
                itm = arr(I)
                arr(I) = arr(j)
                arr(j) = itm
        End If
        Next j
    Next I




End Sub

Public Function RangeExtraction(AList) As String
'AList is a variant that is an array, assumed filled with numbers in ascending order
Const RangeDelim = "-"          'range delimiter
Dim result As String
Dim InRange As Boolean
Dim Posn, I, ub, lb, rangestart, rangelen As Integer
 
result = ""
'find dimensions of AList
ub = UBound(AList)
lb = LBound(AList)
Posn = lb
While Posn < ub
  rangestart = Posn
  rangelen = 0
  InRange = True
  'try to extend the range
  While InRange
    rangelen = rangelen + 1
    If Posn = ub Then
      InRange = False
    Else
      InRange = (AList(Posn + 1) = AList(Posn) + 1)
      Posn = Posn + 1
    End If
  Wend
  If rangelen > 2 Then 'output the range if it has more than 2 elements
    result = result & "," & Format$(AList(rangestart)) & RangeDelim & Format$(AList(rangestart + rangelen - 1))
  Else 'output the separate elements
    For I = rangestart To rangestart + rangelen - 1
      result = result & "," & Format$(AList(I))
    Next
  End If
  Posn = rangestart + rangelen
Wend
RangeExtraction = Mid$(result, 2) 'get rid of first comma!
End Function

1-40,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,21-43,46,49-54,56-64,66,68-78,82-94,96,114,116,121-125

1-43,46,49-54,56-64,66,68-78,82-94,96,114,116,121-125