Microsoft Office Forums - View Single Post - [Solved] Take String of numbers, expand ranges, sort, then compress back into ranges

macropod · 08-22-2016, 05:18 PM

Here's my implementation. I've incorporated two functions I've created for other purposes (one to expand number ranges like 11-15, the other the contract number ranges like 11, 12, 13, 14, 15).

Code:

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

AustinBrister: If you want to increment a certain series of numbers that might be included in the data, you could insert code like:

Code:

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

after:
StrIn = "," & Replace(ParseNumberString(StrIn, ", ", "-"), " ", "") & ","
to decrement them instead you'd use code like:

Code:

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