Thread: Culling consecutive numbers into ranges

I have a spreadsheet that has a column of numbers some of which are consecutive, some of which are not. I would like to have a way to lump all of these chunks of consecutive blocks into ranges. For example:

2759
2760
2761
2762
2764
2765
2766
2768
2769
2773

would return something like:

2759 - 2762
2764 - 2766
2768 - 2769
2773

Any ideas?

Help would be much appreciated.

Quite a few ways to do this, looping etc... not sure how much data you have and/or where you want your resulting values to appear... below is based on replacing original values in A with ranged numbers...

Code:

Public Sub BlockVals()
Dim rngData As Range
Dim lngMin As Long, lngMax As Long, lngCount As Long, lngI As Long
Dim vResults As Variant
Set rngData = Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp))
lngCount = Evaluate("1+SUMPRODUCT(--(" & rngData.Offset(1).Address & ">" & rngData.Address & "+1))")
ReDim vResults(1 To lngCount, 1 To 2)
For lngI = 1 To lngCount
    lngMin = Evaluate("MIN(IF(" & rngData.Address & ">" & lngMax & "," & rngData.Address & "))")
    lngMax = Evaluate("MIN(IF((" & rngData.Offset(1).Address & ">" & rngData.Address & "+1)*(" & rngData.Address & ">" & lngMin & ")," & rngData.Address & "))")
    Cells(lngI, "B") = lngMin & IIf(lngMax, "-" & lngMax, "")
Next lngI
Columns(1).Delete
Set rngData = Nothing
End Sub

Dawned on me somewhat belatedly that you might want to do this with formulae ?

If so... if you ensure there is a cell above the first number ... ie:

Code:

Range: A2:A11

2759
2760
2761
2762
2764
2765
2766
2768
2769
2773

You could in theory return the blocks in B such that:

Code:

B1: 
=SUMPRODUCT(--(A2:A11>(A1:A10+1)))
(gives count of "blocks")

B2: 
=IF(ROWS(B$2:B2)>$B$1,"",SMALL(IF(($A$2:$A$11-$A$1:$A$10)>1,$A$2:$A$11),ROWS(B$2:B2))&LOOKUP(REPT("Z",255),CHOOSE({1,2},"","-"&SMALL(IF(($A$3:$A$12-$A$2:$A$11)>1,$A$2:$A$11),ROWS(B$2:B2)))))
committed with CTRL + SHIFT + ENTER
copied down to say B11

As you alter the values in A2:A11 so you should find the blocks update - obviously based on the premise that the values in A2:A11 are listed in Ascending order and that you are concerned with a step of > 1.

How big (rather than how many) are your numbers ?

If the values > Longs boundaries (–2,147,483,648 to 2,147,486,647) you could perhaps alter variables from Long to Currency.

Provide the subset of 20 numbers you mention.

Hi,

Code:

Sub kTest()
Dim a, i As Long, w(), n As Long, r As Long

r = Range("a" & Rows.Count).End(xlUp).Row
With Range("b2")
    .Resize(r - 1).FormulaR1C1 = "=(rc[-1]-r[-1]c[-1]=1)+0"
    a = .Offset(, -1).Resize(r - 1, 2).Value
    .Resize(r).ClearContents
    ReDim w(1 To UBound(a, 1), 1 To 1)
    n = 1
    For i = 1 To UBound(a, 1)
        If i = 1 Then w(n, 1) = a(i, 1)
        If i > 1 Then
            If a(i, 2) = 0 Then
                w(n, 1) = w(n, 1) & "-" & a(i - 1, 1)
                n = n + 1: w(n, 1) = a(i, 1)
            End If
            If (i = UBound(a, 1)) * (a(i, 2) <> 0) Then w(n, 1) = w(n, 1) & "-" & a(i, 1)
        End If
    Next
    .Resize(n).Value = w
End With
End Sub

Note: Code edited.


HTH

Kris' code didn't work for me based on the sample 20 as it needs (I think) a slight tweak re: last range.

Anyway - below is revision of my original using Currency as opposed to Long as outlined previously and a couple of other tweaks as it didn't work correctly anyway.

Code:

Public Sub BlockVals()
Dim rngData As Range
Dim curMin As Currency, curMax As Currency
Dim lngCount As Long, lngI As Long
Set rngData = Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp))
lngCount = Evaluate("1+SUMPRODUCT(--(" & rngData.Offset(1).Address & ">" & rngData.Address & "+1))")
For lngI = 1 To lngCount
    curMin = Evaluate("MIN(IF(" & rngData.Address & ">" & curMax & "," & rngData.Address & "))")
    curMax = Evaluate("MIN(IF((" & rngData.Offset(1).Address & ">(" & rngData.Address & "+1))*(" & rngData.Address & ">=" & curMin & ")," & rngData.Address & "))")
    curMax = IIf(lngI = lngCount, Application.Max(rngData), curMax)
    Cells(lngI, "B") = curMin & IIf(curMax, "-" & curMax, "")
Next lngI
Set rngData = Nothing
End Sub