Solved

# Creating ranges based on single values (sorted)

Posted on 2014-11-03
68 Views
Dear,

I have a list of serials which are random in sequence however sorted.

If some serials in short sequence (+1 incremental), I want them to show as range while display the serials as it is if not in sequence.

See the attached excel (Column E & F) as my desired result.

Hope to get  a formula or a macro to do the job.

Thanks.
convert-to-range.xlsx
0
Question by:NickHoward
• 5
• 3

Author Comment

ID: 40420113
Any help?
0

LVL 27

Expert Comment

ID: 40420205
Just to clarify by example.  Should these cells be these values?
E46: 101588948
F46: 101588953

Also, do you want empty rows to remain or do you want all the values to be adjacent?
0

Author Comment

ID: 40420323
Correct.

I prefer to copy the range to another sheet without any empty rows.

Thanks.
0

LVL 27

Expert Comment

ID: 40420426
Yep!  The following code will create a new sheet with a set of columns showing all serial numbers and related ranges as in your example:

``````Option Explicit
Sub Transfer_Serial_Nos()
Dim rng, rng2 As Range
Dim cl As Object
Dim intRow As Integer

Application.ScreenUpdating = False
On Error Resume Next
Sheets("Result").Delete
Sheets("Sheet1").Copy after:=Sheets("Sheet1")
ActiveSheet.Name = "Result"
Range("B:F").Delete

Set rng = Range("A3", Range("A3").End(xlDown))
intRow = 1
For Each cl In rng
If Val(cl.Offset(1, 0).Value) = Val(cl.Value) + 1 Then
intRow = intRow - 1
cl.Offset(intRow, 1).Value = cl.Offset(1, 0).Value
If rng2 Is Nothing Then
Else
Set rng2 = Union(rng2, Range(cl.Offset(1, 0).Address))
End If
Else
intRow = 1
End If
Next cl
rng2.EntireRow.Delete
Application.ScreenUpdating = True
MsgBox "Done."
End Sub
``````

It will note all rows to delete (in rng2) and then delete those rows on completion.

The process took just over five minutes to complete on my PC (40K rows).  I didn't expect it to take that long.

Example file with macro attached.

Regards,
-Glenn
EE-convert-to-range.xlsm
0

LVL 27

Accepted Solution

Glenn Ray earned 500 total points
ID: 40420544
This code runs MUCH faster (about one minute):
``````Sub Transfer_Ser_Nos2()
Dim varTest As Variant
Dim boolInRange As Boolean

Application.ScreenUpdating = False
On Error Resume Next
Sheets("Result").Delete
Sheets("Sheet1").Copy after:=Sheets("Sheet1")
ActiveSheet.Name = "Result"
Range("B:F").Delete

Range("A3").Select
Do Until ActiveCell.Value = ""
If boolInRange = False Then varTest = ActiveCell.Value
If Val(ActiveCell.Offset(1, 0).Value) = Val(varTest) + 1 Then
ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(1, 0).Value
varTest = ActiveCell.Offset(0, 1).Value
boolInRange = True
ActiveCell.Offset(1, 0).EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
boolInRange = False
End If
Loop
Application.ScreenUpdating = True
MsgBox "Done."

End Sub
``````

I've added it to the example workbook.

Regards,
-Glenn
EE-convert-to-range.xlsm
0

LVL 27

Expert Comment

ID: 40420583
Thanks, but was there an issue with my solution that only rated a "Good" grade? :-/
0

Author Comment

ID: 40421089
Yeah as it is still slow. I got an example from another forum which takes 10 seconds.
0

LVL 27

Expert Comment

ID: 40421226
Could you post that solution here?  I'm sure it would be helpful to know how it sped up the process.  Thanks.
0

## Featured Post

Question has a verified solution.

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