• Status: Solved
• Priority: Medium
• Security: Public
• Views: 343

# Number ranges displayed in Excel

I have a list of numbers (sometimes in excess of 2,000) that I need to find each and every group of number ranges within this list.  As and example I have:
2889297
2889927
2889928
2889941
2889944
2889299
2889925
2889926
2889931
2889932
2889935
2889936
2889937
2889938
2889939
2889940
2889303
2889950

And first I would probably need the macro or whatever I use to sort by that number:
2889297
2889299
2889303
2889925
2889926
2889927
2889928
2889931
2889932
2889935
2889936
2889937
2889938
2889939
2889940
2889941
2889944
2889950

Then I would need it to display the beginning and ending numbers in each unbroken range like:
Index      Beginning Order      Ending Order
1                    2889297                  2889297
2                    2889299                  2889299
3                    2889303                  2889303
4                    2889925                  2889928
5                    2889931                  2889932
6                    2889935                  2889941
7                    2889944                  2889944
8                    2889950                  2889950

But the macro I have shows index 7 and 8 as a range, though it is not.  It shows index 7 as
Index      Beginning Order      Ending Order
7                    2889944                  2889950
and you can notice the numbers 2889945, 2889946, 2889947, 2889948 are not in the initial list of numbers, thus it would be a broken range, not unbroken.

The Macro I have is:
Sub FindRanges()
Application.ScreenUpdating = False

Dim jump As Integer
Dim range_index As Integer
Dim base_cell As Long
Dim next_1 As Long
Dim next_2 As Long

' Initialize ActiveCells positions, Sorts, and variables
range_index = 1

Sheets("Range List").Select
Cells.Range("A2").Select

Sheets("Order List").Select
Columns("A:A").Select
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Cells.Range("A2").Select

base_cell = ActiveCell.Value
next_1 = ActiveCell.Offset(1, 0).Value
next_2 = ActiveCell.Offset(2, 0).Value

Do
jump = 1

Do
If jump = 1 Then
If next_1 - base_cell <> 1 Then
next_2 = -1
next_1 = -1
End If
End If

If next_2 - next_1 = 1 Then
next_1 = ActiveCell.Offset(jump, 0).Value
next_2 = ActiveCell.Offset(jump + 1, 0).Value
jump = jump + 1
End If
Loop While next_2 - next_1 = 1

' Go to Range List and Input New Range
Sheets("Range List").Select
ActiveCell.Value = range_index
range_index = range_index + 1

ActiveCell.Offset(0, 1).Value = base_cell
If next_1 < 1 Then
ActiveCell.Offset(0, 2).Value = base_cell
Else
ActiveCell.Offset(0, 2).Value = next_1
If next_1 - base_cell = 1 Then
jump = jump + 1
End If
End If

ActiveCell.Offset(1, 0).Select

' Continue cycling through Orders
Sheets("Order List").Select
ActiveCell.Offset(jump, 0).Select
base_cell = ActiveCell.Value
next_1 = ActiveCell.Offset(1, 0).Value
next_2 = ActiveCell.Offset(2, 0).Value
Loop Until next_2 = 0

If next_2 = 0 Then
Sheets("Range List").Select
ActiveCell.Value = range_index
ActiveCell.Offset(0, 1).Value = base_cell
If next_1 = 0 Then
ActiveCell.Offset(0, 2).Value = base_cell
Else
ActiveCell.Offset(0, 2).Value = next_1
End If
End If

Sheets("Range List").Select
Application.ScreenUpdating = True
MsgBox ("Finished scanning range.")
End Sub

Can anyone provide me with a solution to my issue so I can feel comfortable that the ranges are accurate?  FYI, to be used in Excel 2010 or even 2003.

Thanks
0
tourmalinecanyon
• 5
• 2
1 Solution

Commented:
Could you post a very simple example workbook with an example of your data and how you want it outputting.
We can then create an improved code to perform the task for you.
ATB
Steve.
0

Author Commented:
Hi Steve,

The example at the top is exactly what I want.  Enter data on one worksheet and results on the second after running the macro.

Data input:

2889297
2889927
2889928
2889941
2889944
2889299
2889925
2889926
2889931
2889932
2889935
2889936
2889937
2889938
2889939
2889940
2889303
2889950

Data output/results (desired):

Index      Beginning Order      Ending Order
1                    2889297                  2889297
2                    2889299                  2889299
3                    2889303                  2889303
4                    2889925                  2889928
5                    2889931                  2889932
6                    2889935                  2889941
7                    2889944                  2889944
8                    2889950                  2889950

Thanks
Ranges.xls
0

Commented:
OK, the attached workbook has the following code:
``````Sub DoMacro()

Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim r
Dim d As Object
Set d = CreateObject("scripting.dictionary")

r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value

For x = 1 To UBound(r)
If Not d.exists(r(x, 1)) Then
End If

Next x

iMin = WorksheetFunction.Min(r)
iMax = WorksheetFunction.Max(r)

Dim outputArr()
ReDim outputArr(1 To 3, 1 To 1)
ct = 1

For x = iMin To iMax
If d.exists(x) Then
If outputArr(2, ct) = Empty Then
outputArr(1, ct) = ct
outputArr(2, ct) = x
outputArr(3, ct) = x
ElseIf d.exists(x - 1) Then
outputArr(3, ct) = x
End If

End If
If d.exists(x + 1) And Not d.exists(x) Then
ct = ct + 1
ReDim Preserve outputArr(1 To 3, 1 To ct)
End If
Next x
ws.Range("C1").Resize(ct, 3) = Application.Transpose(outputArr)

End Sub
``````

If you paste your values into column A starting at A1 and run the macro you should get your desired result.

Have a test and I will look at implementing it into your workbook (not looked at that yet).
ATB
Steve.
Example.xlsm
0

Commented:
Ranges.xls
0

Author Commented:
The revision you did to my original workbook still has the same problem, but your example.xlsm with the results staying on the same page works exactly as I need for the results.  I'd love to integrate the differences into my original and probably update it to an xlsm and not a excel 2003 format, but I can live with it this way too.

At least my users can get their job done a bit more efficiently!

Thanks

Cheers,
David
0

Commented:
I will re-write to the same format as your file but in xlsm format.
Will post it here tomorrow for you.
any issues post here and I will fix :)

ATB
Steve.
0

Commented:
The attached has a "better" macro in it:
``````Option Explicit
Sub DoMacroSort()

Dim wsFrom As Worksheet: Set wsFrom = Sheets("Order List")
Dim wsTo As Worksheet: Set wsTo = Sheets("Range List")
Dim r: r = wsFrom.Range("A2:A" & wsFrom.Range("A" & Rows.Count).End(xlUp).Row).Value
Dim d As Object: Set d = CreateObject("scripting.dictionary")
Dim x As Long, ct As Long: ct = 1
Dim outputArr(): ReDim outputArr(1 To 3, 1 To 1)
Dim iMin As Long, iMax As Long

For x = 1 To UBound(r)
If Not d.exists(r(x, 1)) Then
End If
Next x

iMin = WorksheetFunction.Min(r)
iMax = WorksheetFunction.Max(r)

Dim TheValues
TheValues = d.keys

Call QuickSort(TheValues, LBound(TheValues), UBound(TheValues))

For x = LBound(TheValues) To UBound(TheValues)

If outputArr(2, ct) = Empty Then
outputArr(1, ct) = ct
outputArr(2, ct) = TheValues(x)
outputArr(3, ct) = TheValues(x)
Else
outputArr(3, ct) = TheValues(x)
End If

If Not x = UBound(TheValues) Then
If Not TheValues(x) + 1 = TheValues(x + 1) Then
ct = ct + 1
ReDim Preserve outputArr(1 To 3, 1 To ct)
End If
End If
Next x

wsTo.Range("A2").Resize(ct, 3) = Application.Transpose(outputArr)

End Sub

Sub QuickSort(arr, Lo As Long, Hi As Long)
Dim varPivot As Variant
Dim varTmp As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = Lo
tmpHi = Hi
varPivot = arr((Lo + Hi) \ 2)
Do While tmpLow <= tmpHi
Do While arr(tmpLow) < varPivot And tmpLow < Hi
tmpLow = tmpLow + 1
Loop
Do While varPivot < arr(tmpHi) And tmpHi > Lo
tmpHi = tmpHi - 1
Loop
If tmpLow <= tmpHi Then
varTmp = arr(tmpLow)
arr(tmpLow) = arr(tmpHi)
arr(tmpHi) = varTmp
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Loop
If Lo < tmpHi Then QuickSort arr, Lo, tmpHi
If tmpLow < Hi Then QuickSort arr, tmpLow, Hi
End Sub
``````

This should work better over larger data sets.
Ranges.xlsm
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.