[SOLVED] Culling consecutive numbers into ranges

comicbook · #1 06-22-2009, 05:26 PM

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.

DonkeyOte · #2 06-23-2009, 06:26 AM

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

DonkeyOte · #3 06-23-2009, 06:49 AM

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

comicbook · #4 06-23-2009, 06:18 PM

Thank you for the quick response.

I tried both the vb script and the formula option.

The vb script gave me a runtime 6: overflow error.

I'm not sure, but it could be because my data set is in the thousands. Although I tried it with a subset of about 20 numbers and had the same failure.

I then tried the formula version and I'm not sure exactly what it did (or was supposed to do) It seemed to fill column B with numbers, but they were not they were not really ranges. I'm not sure how to explain it. Perhaps you could explain what the output should look like.

Thank you very much for your help. I really appreciate it.

DonkeyOte · #5 06-23-2009, 06:25 PM

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.

Krishnakumar · #6 06-23-2009, 09:40 PM

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

comicbook · #7 06-23-2009, 09:53 PM

My numbers are quite large. Here is the subset that I tested with:

8634767317
8634767318
8634767319
8634767320
8634767321
8634767323
8634767325
8634767326
8634767334
8634767339
8634767341
8634767344
8634767345
8634767347
8634767348
8634767349
8634767350
8634767352
8634767353
8634767354

comicbook · #8 06-24-2009, 02:12 AM

Kris,

Your script worked perfectly.

It gave the exact output I was looking for.

Thanks much for the effort.

Thanks also to DonkeyOte for working on this.

This is an immensely helpful forum

DonkeyOte · #9 06-24-2009, 02:19 AM

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

Welcome to the Excel Forum

Forum Statistics