Как скопировать целые строки на основе столбца Дублированное имя на соответствующий лист в VBA?

Question

Мой текущий код будет пытаться скопировать целые строки на основе дублированного имени столбца в соответствующую рабочую таблицу с использованием VBA, как показано ниже. Но это работает только для 1-го дублированного имени, но не для остальных. Когда я просмотрел свой код, я понял, что моя цель (в части для target = Lbound to Ubound part) всегда равна 0, поэтому мне было интересно, почему это всегда 0 в этом случае? Поскольку предполагается, что он находится в диапазоне от 0 до 3?

Sub test()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
    Dim mycell As Range, RANG As Range, Mname As String, Rng As Range


Dim r As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    With Sheets(1)
        ' Build a range (RANG) between cell F2 and the last cell in column F
        Set RANG = Range(.Cells(2, "A"), .Cells(.Rows.count, "A").End(xlUp))
    End With


    ' For each cell (mycell) in this range (RANG)
    For Each mycell In RANG
        Mname = mycell.Value
        ' If the count of mycell in RANG is greater than 1, then set the value of the cell 1 across to the right of mycell (i.e. column G) as "Duplicate Found"
        If Application.WorksheetFunction.CountIf(RANG, mycell.Value) > 1 Then


        If dict.count > 0 And dict.Exists(Mname) Then
        dict(Mname) = mycell.Row()
        Else
        dict.Add Mname, mycell.Row()
        End If

        End If
    Next mycell

Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Dim Arr: Arr = Array(Key)
Dim f As Variant

For x = 1 To 4
    Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.count))
    cs.Name = "Names" & x
Next x

    'Display result in debug window (Modify to your requirement)
    Startrow = 2


For Each Key In dict.Keys
Set Rng = ws.Range("A" & Startrow & ":A" & dict(Key))

'Create 3 Sheets, move them to the end, rename

lr = dict(Key)

v = dict.Keys 'put the keys into an array 

'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?


   'Loop through each row
    For i = Startrow To lr

        'Create Union of target rows
        If ws.Range("A" & i) = v(Target) Then
            If Not CopyMe Is Nothing Then
                Set CopyMe = Union(CopyMe, ws.Range("A" & i))
            Else
                Set CopyMe = ws.Range("A" & i)
            End If
        End If
    Next i


    Startrow = dict(Key) + 1

    'Copy the Union to Target Sheet
    If Not CopyMe Is Nothing And Target = 0 Then
        CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names1").Range("A1")
        Set CopyMe = Nothing
    End If
        If Not CopyMe Is Nothing And Target = 1 Then
        CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names2").Range("A1")
        Set CopyMe = Nothing
    End If
     If Not CopyMe Is Nothing And Target = 2 Then
        CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names3").Range("A1")
        Set CopyMe = Nothing
    End If
      If Not CopyMe Is Nothing And Target = 3 Then
        CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names4").Range("A1")
        Set CopyMe = Nothing
    End If
Next Target

    Next

End Sub

Основной лист

В случае дублирования имени Джона :

В случае дублирования имени Алисы

Обновленный код:

Sub test()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
    Dim mycell As Range, RANG As Range, Mname As String, Rng As Range


Dim r As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    With Sheets(1)
        ' Build a range (RANG) between cell F2 and the last cell in column F
        Set RANG = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
    End With


    ' For each cell (mycell) in this range (RANG)
    For Each mycell In RANG
        Mname = mycell.Value
        ' If the count of mycell in RANG is greater than 1, then set the value of the cell 1 across to the right of mycell (i.e. column G) as "Duplicate Found"
        If Application.WorksheetFunction.CountIf(RANG, mycell.Value) > 1 Then


        If dict.Count > 0 And dict.Exists(Mname) Then
        dict(Mname) = mycell.Row()
        Else
        dict.Add Mname, mycell.Row()
        End If

        End If
    Next mycell

Dim StartRow As Long
StartRow = 2

Dim Key As Variant
Dim lr As Long, v As Variant
For Each Key In dict.Keys
    Set Rng = ws.Range("A" & StartRow & ":A" & dict(Key))
    lr = dict(Key)
    v = dict.Keys               'put the keys into an array

    'Create 3 Sheets, move them to the end, rename
    'Loop through each name in array
    For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
       'Loop through each row
        For i = StartRow To lr
            'Create Union of target rows
            If ws.Range("A" & i) = v(Target) Then
                If Not CopyMe Is Nothing Then '<---object required error at If Not copyme...
                    Set CopyMe = Union(CopyMe, ws.Range("A" & i))
                Else
                    Set CopyMe = ws.Range("A" & i)
                End If
            End If
        Next i

        StartRow = dict(Key) + 1
        'Copy the Union to Target Sheet
        If Not CopyMe Is Nothing Then
            Mname = "Name" & CStr(Target + 1)
            CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets(Mname).Range("A1")
            Set CopyMe = Nothing
        End If
    Next Target
Next Key

End Sub

Answer 1

Используйте словарь для начальной строки и другой для конечной строки. Затем легко определить диапазон повторяющихся строк для каждого имени и скопировать их на новый лист.

Sub CopyDuplicates()

    Dim wb As Workbook, ws As Worksheet
    Dim irow As Long, iLastRow As Long

    Dim dictFirstRow As Object, dictLastRow As Object, sKey As String
    Set dictFirstRow = CreateObject("Scripting.Dictionary") ' first row for name
    Set dictLastRow = CreateObject("Scripting.Dictionary") ' last row for name

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    iLastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

    ' build dictionaries
    For irow = 1 To iLastRow
        sKey = ws.Cells(irow, 1)
        If dictFirstRow.exists(sKey) Then
           dictLastRow(sKey) = irow
        Else
           dictFirstRow.Add sKey, irow
           dictLastRow.Add sKey, irow
        End If
    Next

    ' copy range of duplicates
    Dim k, iFirstRow As Long, rng As Range, wsNew As Worksheet
    For Each k In dictFirstRow.keys

        iFirstRow = dictFirstRow(k)
        iLastRow = dictLastRow(k)

        ' only copy duplicates
        If iLastRow > iFirstRow Then
            Set wsNew = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
            wsNew.Name = k

            Set rng = ws.Rows(iFirstRow & ":" & iLastRow).EntireRow
            rng.Copy wsNew.Range("A1")
            Debug.Print k, iFirstRow, iLastRow, rng.Address
        End If
    Next

    MsgBox "Done"

End Sub

Answer 2

Джон, я потратил час на проработку твоего кода - исправляя и комментируя. У меня действительно хорошее чувство того, как уверенность вырвалась из твоего разума, когда ты вошел в последнюю треть кода. То же самое случилось со мной. Я видел, как вы, вероятно, и сделали, что концепция была настолько далека от истины, что ее очень трудно спасти. Поэтому я написал код, который, вероятно, делает то, что вы хотите. Пожалуйста, попробуйте это.

Sub TransferData()

    Dim Src As Variant                      ' source data
    Dim Ws As Worksheet                     ' variable target sheet
    Dim WsName As String
    Dim Rl As Long                          ' last row
    Dim R As Long                           ' row
    Dim C As Long                           ' column

    With ThisWorkbook.Sheets("TestData")
        ' Copy all values between cell A2 and the last cell in column F
        Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
        Src = Range(.Cells(2, "A"), .Cells(Rl, "F")).Value
    End With

    Application.ScreenUpdating = False
    For R = 1 To UBound(Src)
        WsName = Trim(Split(Src(R, 1))(0))        ' first word in A2 etc
        On Error Resume Next
        Set Ws = Worksheets(WsName)
        If Err Then
            With ThisWorkbook.Sheets
                Set Ws = .Add(After:=Sheets(.Count))
            End With
            Ws.Name = WsName
        End If

        On Error Goto 0
        ' append data
        With Ws
            Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
            For C = 1 To UBound(Src, 2)
                With .Rows(Rl + 1)
                    .Cells(C).Value = Src(R, C)
                End With
            Next C
        End With
    Next R

    Application.ScreenUpdating = True
End Sub

Код не использует словарь. Вот почему он намного короче и гораздо эффективнее. Он просто сортирует данные напрямую на разные листы на основе того, что он находит в столбце А. Нет ограничений на количество листов, которые вам могут понадобиться.

Обратите внимание, что лист, на котором у меня были данные, называется " TestData "в этом коде. Это должен быть тот, кто в вашем проекте ответил на прозвище Sheets (1) , скорее всего, он же ThisWorkbook.Worksheets ("Sheet1") .

Answer 3

Я не смог найти ошибку, потому что не хотел настраивать рабочую книгу, которая позволила бы мне тщательно протестировать ваш код. Однако я прочитал ваш код и обнаружил, что вы очень слабо объявляли переменные. Я предлагаю вам ввести Option Explicit в верхней части кода.

Чтобы позвонить на Key, «Ключ» вызывает проблемы. Наилучшая практика предполагает, что вы не используете ключевые слова VBA в качестве имен переменных. В контексте вашего кода, For Each Key In Dict.Keys требует Key в качестве варианта. Отсутствие объявления может сделать его вариантом по умолчанию, но если это слово также резервирует VBA для собственного использования, может возникнуть путаница.

Другая идея заключается в том, что вы могли поставить точку останова на For Target = LBound(v) To UBound(v) - 1. Когда код остановится, Target будет равен нулю, поскольку строка еще не выполнена. Но после первого l oop выполнение не вернется к этой строке. Таким образом, вы могли пропустить Target принятие значения, и ошибка может быть в другом месте. Убедитесь, что вы ставите точку останова на первой строке после оператора For. Вы также можете добавить Debug.Print LBound(v), UBound(v) перед оператором For или проверить эти значения в окне Locals.

Ниже приведен раздел кода, в который я добавил несколько объявлений переменных и внес изменения в код, который создает и называет новые листы.

Dim StartRow As Long
StartRow = 2

Dim Key As Variant
Dim lr As Long, v As Variant
For Each Key In Dict.Keys
    Set Rng = Ws.Range("A" & StartRow & ":A" & Dict(Key))
    lr = Dict(Key)
    v = Dict.Keys               'put the keys into an array

    'Create 3 Sheets, move them to the end, rename
    'Loop through each name in array
    For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
       'Loop through each row
        For i = StartRow To lr
            'Create Union of target rows
            If Ws.Range("A" & i) = v(Target) Then
                If Not CopyMe Is Nothing Then
                    Set CopyMe = Union(CopyMe, Ws.Range("A" & i))
                Else
                    Set CopyMe = Ws.Range("A" & i)
                End If
            End If
        Next i

        StartRow = Dict(Key) + 1
        'Copy the Union to Target Sheet
        If Not CopyMe Is Nothing Then
            Mname = "Name" & CStr(Target + 1)
            CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets(Mname).Range("A1")
            Set CopyMe = Nothing
        End If
    Next Target
Next Key