Solved

Number ranges displayed in Excel

Posted on 2014-01-22
7
272 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
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 
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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

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…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

707 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

16 Experts available now in Live!

Get 1:1 Help Now