时间戳

首页 > 解决方案 > 循环遍历数据集并停止并选择

excel - 循环遍历数据集并停止并选择

问题描述

我有一个要循环遍历的数据列表。在 A 列中，数据将有一个代码，当此代码更改时，我希望循环停止并选择上面的所有代码。我之前问过这个问题并得到了有用的建议，我已将提供的代码粘贴在下面的错误 1004 中。

当我使用 F8 浏览代码时，它似乎确实遍历了 A 列中的代码，但不会停止或选择具有相同代码的所有数据。

Sub test()

    Dim LastRow As Long, i As Long, j As Long, StartPoint As Long
    Dim strValue As String

    strValue = ""
    StartPoint = 2

    'With statement refer to Sheet1. Change if needed
    With ThisWorkbook.Worksheets("Sheet1")

        'Find Last row of column A in Sheet1
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'Loop starting from row 2 to LastRow variale. Change Starting position if needed
        For i = 2 To LastRow

            If i >= StartPoint Then

                strValue = .Range("A" & i).Value

                For j = i + 1 To LastRow

                    If .Range("A" & j).Value <> strValue Then
                        .Range("A" & j - 1 & ":B" & j - 1).Select
                        Exit For
                    End If

                Next j

                StartPoint = j

            End If

        Next i

    End With

End Sub

Excel 工作表将如下所示：

Portfolio   Owner Name
7000107510  Owner Name 1
7000107510  Owner Name 1
7000107510  Owner Name 1
7000107510  Owner Name 1
7000107510  Owner Name 1
7000108762  Owner Name 2
7000108762  Owner Name 2
7000108762  Owner Name 2
7000110007  Owner Name 3
7000110007  Owner Name 3
7000114711  Owner Name 4
7000114711  Owner Name 4

标签： excelvba

解决方案

我会这样做：

Option Explicit
Sub test()

    Dim LastRow As Long
    Dim C As Range
    Dim CopyRange As Range


    'With statement refer to Sheet1. Change if needed
    With ThisWorkbook.Worksheets("Sheet1")

        'Find Last row of column A in Sheet1
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'Loop starting from row 3 to LastRow variale. Change Starting position if needed
        For Each C In .Range("A2:A" & LastRow)
            If C = C.Offset(-1) Then 'check if the ID is the same as the row above
                'if it is, create a range with the cells with the same ID
                If CopyRange Is Nothing Then 'start the range if is empty
                    Set CopyRange = .Range("A" & C.Row & ":B" & C.Row)
                Else 'add the new cells if not empty
                    Set CopyRange = Union(CopyRange, .Range("A" & C.Row & ":B" & C.Row))
                End If
            Else 'when you find a different ID then copy the range you already had
                CopyRange.Copy Destination:=Range("A1") 'change Range("A1") for the range where you want to paste
                Set CopyRange = Nothing 'empty the range
                Set CopyRange = C 'renew the range with the current ID (new one)
            End If
        Next C
    End With

End Sub

推荐阅读