Take String of numbers, expand ranges, sort, then compress back into ranges

AustinBrister · #1 07-19-2016, 02:58 PM

Hello, I have quite the issue I am looking to resolve. I've been searching all over the internet now for at least 3 hours with no luck.

I have a word document with thousands of little areas with seemingly random messes of numbers, such as this:

Code:

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

I need to create VBA code that will allow me to take each of those little lists, expand those ranges (i.e., "39-41" would become separate entries of "39, 40, 41"), sort the list, then compress back into number ranges, where applicable.

Ideally I would just be able to select the numbers and fire the macro. I have found alphabetical sorting options, but I need numerical sorting.

Thanks in advance!!

Guessed · #2 07-19-2016, 04:44 PM

And what do you want to do if the same page number appears twice?

I don't have the excitement levels to code this at present but would approach this in the following way:
Replace all spaces with nothing
Split into an array
Loop the array to convert the dashes into a series of numbers separated by commas
Convert the array back into a string separated by commas
Split into an array a second time and do a bubblesort to arrange them in ascending order
Convert the final array back into a string separated by commas

You could remove a couple of steps if you converted the initial string into an ado.recordset which simplifies the sorting requirement.

AustinBrister · #3 07-19-2016, 06:55 PM

Ah, good point. I also want to de-duplicate.

I tried to do this stuff myself, but I'm just missing knowledge of some of the fundamentals. Not really familiar with arrays.

AustinBrister · #4 07-19-2016, 07:29 PM

Here's what I have so far:

Code:

Sub ListExpandSortDeDupCompress()

Dim arrItems() As String
Dim OGList As String
Dim SplitList() As String
Dim FinalArray() As Variant
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 Variant
For i = LBound(SplitList) + 1 To UBound(SplitList)
    If Not IsInArray(SplitList(i), FinalArray) Then
    FinalArray(UBound(FinalArray)) = SplitList(i)
    ReDim Preserve FinalArray(1 To UBound(FinalArray) + 1) As Variant
    End If
Next i

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



End Sub

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

First of all, THANK YOU SO MUCH!

It looks like I'm really getting somewhere.

The only final step I need to do is to creating the summarized ranges. I think what I need to do there is another loop of some sort that compares sequential entries. If the next entry is one step above the current entry, then the loop (or nested if/then?) would keep going until it finds either the end of the array or an entry that is not sequential. Honestly, this is probably the most daunting task for me. I'm not sure how to structure that loop/whatever.

AustinBrister · #5 07-19-2016, 09:02 PM

I found this function. However, it isn't doing anything to my string. Is that because I need to convert my string to a long/integer array ?

Code:

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

AustinBrister · #6 07-19-2016, 09:13 PM

OMG... I did it.....

Code:

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

Place that into a word VBA project. In the word document, type this:

Code:

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

Select those numbers, then run the Macro. Output should be:

Code:

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

AustinBrister · #7 07-20-2016, 10:29 AM

Every now and then it will fail to Deduplicate. Any pointers as to why this may be?

Guessed · #8 07-20-2016, 04:54 PM

Well done, you've come a long way on this already. Can you provide an example string that that demonstrates the problem with de-duplicating? I thought it might be how you handle the start or end of a run but couldn't replicate it with anything obvious.

As I mentioned in the first post, a recordset is an alternative way of doing this and this would allow you to make use of the SQL SELECT DISTINCT query to remove any duplicates without stepping.

I will try to find some time later today to have a closer look at the code to see if there is anything to fix.

AustinBrister · #9 07-21-2016, 09:24 AM

Thanks again for your help. Honestly, I barely understand how all of these work. I just started taking everything in bite sized chunks as you suggested and using a TON of googling. I couldn't figure out the SQL or ado.recordset stuff and so I had to resort to other options.

Here is an example of a list that doesn't properly deduplicate one of the entries:

47, 23, 26, 55, 51, 30, 38, 4, 35, 59, 64, 28, 44, 29, 47, 8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 47, 23, 26, 55, 51, 30, 38, 4, 35, 47, 23, 26, 55, 51, 30, 38, 4, 35, 59, 64, 28, 44, 29, 47, 47, 23, 26, 55, 51, 30, 38, 4, 35, 59, 64, 28, 44, 29, 47, 8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61,8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61,59, 64, 28, 44, 29, 47, 8, 10, 30, 55, 1, 26, 48, 34, 29, 13, 50, 2, 56, 9, 16, 49, 51, 17, 62, 58, 63, 43, 26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61,26, 32, 46, 12, 18, 39, 64, 41, 45, 5, 1, 40, 41, 45, 2, 47, 6, 30, 5, 37, 26, 56, 52, 9, 52, 27, 1, 4, 2, 29, 3, 32, 41, 10, 57, 62, 39, 25, 54, 18, 12, 52, 43, 53, 46, 24, 36, 46, 63, 61, 34, 55, 58, 46, 26, 40, 26, 9, 9, 51, 10, 57, 61

For some reason, 61 is repeated once.

gmaxey · #10 07-21-2016, 02:33 PM

Austin,

Over the years I also did tons of Goggling and have cobbled together similar processes, but none started out with a jumbled mess as you have illustrated here. I became interested when I saw you code and have been waiting anxiously for Guessed to return and show us how to use the Record.

After seeing nothing further from him today, I decide to reconstruct your code in my own style (probably unique and unlike the ROW developers) and incorporate a dictionary to screen the duplicates. At the end of the day the result is the same so I hope not to imply that I think my changes makes it any better. Just showing a different approach.

I don't know where he is, but Macropod (who haunts this forum) has previously posted a method as well, but I can't find it now.

Code:

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

Guessed · #11 07-21-2016, 03:59 PM

Austin

You are getting duplicates because of the string you are using as the input. You are selecting the text in Word and including the paragraph mark (which in this case is preceded by the number 61). Then the paragraph mark is included in all the processing so that you eliminate all excess '61's and also have a '61return'. It should be easy to remove this in your code early by including a replace line to remove Chr(13)

Code:

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

Greg's code anticipated your starting selection could include a paragraph mark and he solved that issue in his function fcnKillWhiteSpace - personally I think he should have named it KillFcnWhiteSpace

.

gmaxey · #12 07-21-2016, 04:34 PM

Andrew,

I'm dealing with that at the start:
strNumberList = fcnKillWhiteSpace(Selection.Text)

... which probably should include en and em spaces just to be complete.

gmaxey · #13 07-21-2016, 04:35 PM

Andrew,

I saw your post earlier but not your edit. Sorry for stating what you already knew.

Guessed · #14 07-21-2016, 10:04 PM

I've discovered that the Recordset method doesn't actually allow use of Select Distinct in the SQL since we don't have an external table to apply the query to. A recordset does allow easy sorting though so it is still worthwhile using it for that purpose.

I've noticed that there is a flaw in the fcnConcatenateNumbers function when a run is only two numbers long. This is causing 13 to disappear from the result in the massive number set you posted above.

gmaxey · #15 07-21-2016, 10:44 PM

Andrew,

Unfortunately we came to the same discovery. Only I thought perhaps that you had discovered something previously that did work :-(

You are also correct about the flaw which Austin had right to start with. I've also beefed up the fcnKillWhiteSpace (which you like to refer to by its more colorful name).

Code:

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
Sub Test()
   MsgBox fcnKillWhiteSpace("A B V")
End Sub
Function fcnKillWhiteSpace(strRaw As String) As String
Dim arrSpaces() As String
Dim lngIndex As Long
Dim strTemp As String
  strTemp = strRaw
  arrSpaces = Split("9,11,13,32,160,8194,8195,8196,8197", ",")
  For lngIndex = 0 To UBound(arrSpaces)
    strTemp = Replace(strTemp, ChrW(arrSpaces(lngIndex)), "")
  Next lngIndex
  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
      For lngIndex = lngConsecutiveSpanStart To lngConsecutiveSpanStart + lngConsecutiveCount - 1
        strTemp = strTemp & "," & Format$(varNumbers(lngIndex))
      Next
    End If
    lngElement = lngConsecutiveSpanStart + lngConsecutiveCount
  Wend
  fcnConcatenateNumbers = Mid$(strTemp, 2) 'Get rid of first comma!
lbl_Exit:
  Exit Function
End Function

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Dynamic chart ranges	GlowingApple	Excel	1	02-17-2016 07:18 PM
Problem with have a chart with different data ranges	expert4knowledge	Excel	2	09-09-2014 06:27 AM
Compare content of two ranges INCLUDING FORMATTING	delasson	Word VBA	3	12-10-2012 03:54 AM
How to use named ranges in excel vba?	bosve73	Excel Programming	4	01-25-2012 09:26 AM
Dynamic Named Ranges using text	hannu	Excel	0	06-22-2010 04:42 PM