Прокрутите набор данных, остановитесь и выберите

Question

У меня есть список данных, которые я хочу просмотреть. В столбце 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

Answer 1

Вот как бы я это сделал:

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

Answer 2

Это сделает работу:

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 + 1

            If i >= StartPoint Then

                If Not .Range("A" & i).Value = .Range("A" & i - 1).Value Then
                    .Range("A" & StartPoint & ":C" & i - 1).Select
                    StartPoint = i

                   ' Add your additional code here After Selecting   

                End If


            End If

        Next i

    End With

End Sub