如何将基于列 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称为“Key”是自找麻烦。 最佳实践建议您不要使用 VBA 关键字作为变量名。 在您的代码上下文中， For Each Key In Dict.Keys要求Key是一个变体。 未声明将使其成为默认的变体，但如果它也是 VBA 保留供自己使用的词，则可能会出现混淆。

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

Answer 2

开始行使用字典，结束行使用字典。 然后可以直接确定每个名称的重复行范围并将它们复制到新工作表中。

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 3

约翰，我花了一个小时来研究你的代码 - 更正和评论。 当你进入代码的最后三分之一时，我对信心是如何从你的脑海中逃脱的感觉非常好。 这样的事情我也经历过。 我看到，正如你可能已经看到的那样，这个概念太离谱了，很难挽救。 所以我写了可能做你想要的代码。 请尝试一下。

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

该代码不使用字典。 这就是为什么它更短、更高效的原因。 它只是根据在 A 列中找到的内容将数据直接排序到不同的工作表中。您可能需要的工作表数量没有限制。

请注意，在此代码中，我拥有数据的工作表称为“TestData”。 它应该是您项目中响应名字Sheets(1) 的那个，最有可能又名ThisWorkbook.Worksheets("Sheet1") 。