Solved

Number ranges displayed in Excel

Posted on 2014-01-22
7
283 Views
Last Modified: 2014-01-23
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
  Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
    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
Comment
Question by:tourmalinecanyon
  • 5
  • 2
7 Comments
 
LVL 24

Expert Comment

by:Steve
ID: 39800877
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
 
LVL 1

Author Comment

by:tourmalinecanyon
ID: 39801048
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
 
LVL 24

Accepted Solution

by:
Steve earned 500 total points
ID: 39801200
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
    d.Add r(x, 1), Null
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

Open in new window


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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 24

Expert Comment

by:Steve
ID: 39801210
The attached copy of your workbook should do the task.
Ranges.xls
0
 
LVL 1

Author Closing Comment

by:tourmalinecanyon
ID: 39801368
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
 
LVL 24

Expert Comment

by:Steve
ID: 39801376
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
 
LVL 24

Expert Comment

by:Steve
ID: 39803336
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
        d.Add r(x, 1), Null
    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

Open in new window


This should work better over larger data sets.
Ranges.xlsm
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

911 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now