Create ranges out of rows VBA

Question

I have multiple rows which are sometimes in order and sometimes not. Out of rows which are in order, I would need to create a range, which are not in order just to copy the number.

The thing is, the most rows in order can be even 20.

For example cells:
1
3
5
6
7
8
9
10
13
14
15

There would be:
1
3
5-10
13-15

Is it possible to code it?

Thanks

Answer 1

If I understood your question correctly, you are not looking to address a range, but rather want an output table. This code below should provide you with just that. My input numbers are in column A, and the output is in column B.

Sub sequentials()

Dim tws As Worksheet
Dim tmpRowA, tmpRowB As Integer
Dim seq() As Long

Dim frA, frB, lrA As Integer       'firstrow col A, col B, lastrow of data


    Set tws = ThisWorkbook.Worksheets("Sheet1")

    frA = 2
    frB = 2

    lrA = tws.Range("A1000000").End(xlUp).Row


    'Input in column A, Output in column B
    'Headers in Row 1

    ReDim seq(0 To lrA - 1)

    seq(0) = -2
    seq(1) = tws.Range("A" & frA).Value

    tmpRowA = frA
    tmpRowB = frB

    tws.Range("B" & frB & ":B" & lrA).NumberFormat = "@"

    For r = frA + 1 To lrA

    If r = 23 Then
        r = 23
    End If

        With tws

            seq(r - 1) = .Range("A" & r).Value

            If seq(r - 1) = seq(r - 2) + 1 Then
                If r = lrA Then
                    .Range("B" & tmpRowB).Value = .Range("A" & tmpRowA - 1).Value & "-" & seq(r - 1)
                End If
            Else
                If seq(r - 2) = seq(r - 3) + 1 Then
                    .Range("B" & tmpRowB).Value = .Range("A" & tmpRowA - 1).Value & "-" & seq(r - 2)
                Else
                    .Range("B" & tmpRowB).Value = seq(r - 2)
                End If
                tmpRowB = tmpRowB + 1
                tmpRowA = r + 1

                If r = lrA Then
                    .Range("B" & tmpRowB).Value = seq(r - 1)
                End If

            End If

        End With

    Next r


End Sub

Proof of concept:

Answer 2

if you want the address of all consecutive ranges you could use:

Option Explicit

Sub main()
    Dim rangeStrng As String

    With Worksheets("MyRowsSheet") '<--| change "MyRowsSheet" with your actual sheet name
        rangeStrng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants).Areas.Parent.Address(False, False)
    End With
End Sub

if you want only the rows range then you could use:

Option Explicit

Sub main2()
    Dim rng As Range
    Dim rowsRangeStrng As String

    With Worksheets("MyRowsSheet") '<--| change "MyRowsSheet" with your actual sheet name
        For Each rng In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
            If rng.Rows.Count = 1 Then
                rowsRangeStrng = rowsRangeStrng & rng.Rows(1).Row & ","
            Else
                rowsRangeStrng = rowsRangeStrng & rng.Rows(1).Row & "-" & rng.Rows(rng.Rows.Count).Row & ","
            End If
        Next rng
    End With
    If rowsRangeStrng <> "" Then rowsRangeStrng = Left(rowsRangeStrng, Len(rowsRangeStrng) - 1)
End Sub

Answer 3

Assuming your data starts with A1.... and

required results will be printed at C column.

Try with below code

Sub test()
    Dim i As Long, lastrow As Long, incre As Long
    Dim startno As Variant
    Dim endno As Variant
    incre = 1
    lastrow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To lastrow
        If Cells(i, 1) = (Cells(i + 1, 1) - 1) Then
            startno = Cells(i, 1)
            Do While Cells(i, 1) = (Cells(i + 1, 1) - 1)
                endno = Cells(i + 1, 1)
                i = i + 1
            Loop
            Cells(incre, 3) = "'" & startno & "-" & endno
            incre = incre + 1
        Else
            Cells(incre, 3) = Cells(i, 1)
            incre = incre + 1
        End If
    Next i
End Sub