如何将基于列A重复名称的整个行复制到VBA中的相应工作表？

Question

我当前的代码将尝试使用VBA将基于列A重复名称的整个行复制到其各自的工作表中，如下所示。但是它仅适用于第一个重复的名称，而不适用于其余的名称。当我查看代码时，我意识到我的目标（在target = Lbound到Ubound的部分）始终为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

我找不到错误，因为我不想设置使我能够彻底测试您的代码的工作簿。但是，我确实阅读了您的代码，发现您在声明变量方面非常松懈。建议您在代码顶部输入Option Explicit。

[将Key称为“键”是自找麻烦。最佳实践建议您不要将VBA关键字用作变量名。在您的代码上下文中，For Each Key In Dict.Keys要求Key是变体。如果未声明，默认情况下会使其成为变体，但是如果它也是VBA为自己使用保留的词，则可能会引起混淆。

另一个想法是，您可能在For Target = LBound(v) To UBound(v) - 1上设置了一个断点。当代码停止时，Target将为零，因为该行尚未执行。但是在第一个循环执行之后将不会返回到这一行。因此，您可能会错过Target取一个值，并且该错误可能在其他地方。确保将断点放在For语句之后的第一行。您也可以在Debug.Print LBound(v), UBound(v)语句之前添加For或在“本地”窗口中检查这些值。

下面是代码部分，我添加了几个变量声明，并对创建和命名新工作表的代码进行了修改。

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