Question

我有多行有时是有序的，有时不是。在按顺序排列的行中，我需要创建一个范围，这些范围不仅仅是为了复制数字。

问题是，顺序最多的行甚至可以是20行。

例如细胞：
1
3
5
6
7
8
9
10个
13个
14个
15

会有：
1
3
5-10
13-15

可以编码吗？

由于

Answer 1

假设您的数据以A1 ....和

开头

所需的结果将打印在C栏。

尝试使用以下代码

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

Answer 2

如果您想要使用的所有连续范围的地址：

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

如果您只想要行范围，那么您可以使用：

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

如果我理解你的问题，你不是要寻找一个范围，而是想要一个输出表。下面的代码应该为您提供。我的输入数字在A列，输出在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

概念证明：

创建行VBA范围

3 个答案: