[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 75
  • Last Modified:

Creating ranges based on single values (sorted)

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
NickHoward
Asked:
NickHoward
  • 5
  • 3
1 Solution
 
NickHowardAuthor Commented:
Any help?
0
 
Glenn RayExcel VBA DeveloperCommented:
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
 
NickHowardAuthor Commented:
Correct.

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

Hope I have answered your questions.

Thanks.
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
Glenn RayExcel VBA DeveloperCommented:
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.DisplayAlerts = False
    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
                Set rng2 = Range(cl.Offset(1, 0).Address)
            Else
                Set rng2 = Union(rng2, Range(cl.Offset(1, 0).Address))
            End If
        Else
            intRow = 1
        End If
    Next cl
    rng2.EntireRow.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Done."
End Sub

Open in new window


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
 
Glenn RayExcel VBA DeveloperCommented:
This code runs MUCH faster (about one minute):
Sub Transfer_Ser_Nos2()
    Dim varTest As Variant
    Dim boolInRange As Boolean
    
    Application.DisplayAlerts = False
    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.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Done."

End Sub

Open in new window


I've added it to the example workbook.

Regards,
-Glenn
EE-convert-to-range.xlsm
0
 
Glenn RayExcel VBA DeveloperCommented:
Thanks, but was there an issue with my solution that only rated a "Good" grade? :-/
0
 
NickHowardAuthor Commented:
Yeah as it is still slow. I got an example from another forum which takes 10 seconds.
0
 
Glenn RayExcel VBA DeveloperCommented:
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

Receive 1:1 tech help

Solve your biggest tech problems alongside global tech experts with 1:1 help.

  • 5
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now