如何将基于 A 列重复名称的整行复制到 VBA 中的相应工作表？
How to copy entire rows based on column A duplicated name to its respective worksheet in VBA?
我当前的代码将尝试使用 VBA 将基于重复名称列的整行复制到其各自的工作表中，如下所示。但它只适用于第一个重复的名称，而不适用于其余的。当我查看我的代码时，我意识到我的目标（在 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
主工作表
如果约翰姓名重复：
Alice名字重复的情况
更新代码：
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
我找不到错误，因为我不想设置使我能够彻底测试您的代码的工作簿。但是，我确实通读了您的代码，发现您在声明变量方面非常松懈。我建议您在代码顶部输入 Option Explicit。
称Key为"Key"是自找麻烦。最佳实践建议您不要使用 VBA 关键字作为变量名。在您的代码上下文中，For Each Key In Dict.Keys 要求 Key 成为变体。默认情况下，未声明会使它成为变体，但如果它也是一个词 VBA 保留供自己使用，则可能会出现混淆。
另一个想法是您可能在 For Target = LBound(v) To UBound(v) - 1 上放置了一个断点。当代码在那里停止时，Target 将为零，因为该行尚未执行。但是第一次循环执行后不会return到这一行。所以你可能错过了 Target 取值并且错误可能在其他地方。确保将断点放在 For 语句之后的第一行。您还可以在 For 语句之前添加 Debug.Print LBound(v), UBound(v) 或在 Locals window.
中检查这些值
下面是代码部分，我在其中添加了几个变量声明并对创建和命名新工作表的代码进行了修改。
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
开始行使用字典，结束行使用另一个字典。然后直接确定每个名称重复行的范围并将它们复制到新的 sheet.
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
约翰，我花了一个小时完成您的代码 - 更正和评论。当您进入代码的最后三分之一时，我真的很清楚信心是如何从您的脑海中消失的。这样的事情我也经历过。我看到，就像你可能看到的那样，这个概念离题太远，很难挽救。所以我写了可能做你想做的代码。请试一试。
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 列中找到的内容将数据直接排序到不同的 sheet。您可能需要的 sheet 的数量没有限制。
观察到我拥有数据的 sheet 在此代码中称为 "TestData"。它应该是您项目中响应绰号 Sheets(1) 的那个，很可能又名 ThisWorkbook.Worksheets("Sheet1").
我当前的代码将尝试使用 VBA 将基于重复名称列的整行复制到其各自的工作表中，如下所示。但它只适用于第一个重复的名称，而不适用于其余的。当我查看我的代码时，我意识到我的目标（在 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
主工作表
如果约翰姓名重复：
Alice名字重复的情况
更新代码：
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
我找不到错误，因为我不想设置使我能够彻底测试您的代码的工作簿。但是，我确实通读了您的代码，发现您在声明变量方面非常松懈。我建议您在代码顶部输入 Option Explicit。
称Key为"Key"是自找麻烦。最佳实践建议您不要使用 VBA 关键字作为变量名。在您的代码上下文中，For Each Key In Dict.Keys 要求 Key 成为变体。默认情况下，未声明会使它成为变体，但如果它也是一个词 VBA 保留供自己使用，则可能会出现混淆。
另一个想法是您可能在 For Target = LBound(v) To UBound(v) - 1 上放置了一个断点。当代码在那里停止时，Target 将为零，因为该行尚未执行。但是第一次循环执行后不会return到这一行。所以你可能错过了 Target 取值并且错误可能在其他地方。确保将断点放在 For 语句之后的第一行。您还可以在 For 语句之前添加 Debug.Print LBound(v), UBound(v) 或在 Locals window.
下面是代码部分，我在其中添加了几个变量声明并对创建和命名新工作表的代码进行了修改。
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
开始行使用字典，结束行使用另一个字典。然后直接确定每个名称重复行的范围并将它们复制到新的 sheet.
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
约翰，我花了一个小时完成您的代码 - 更正和评论。当您进入代码的最后三分之一时，我真的很清楚信心是如何从您的脑海中消失的。这样的事情我也经历过。我看到，就像你可能看到的那样，这个概念离题太远，很难挽救。所以我写了可能做你想做的代码。请试一试。
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 列中找到的内容将数据直接排序到不同的 sheet。您可能需要的 sheet 的数量没有限制。
观察到我拥有数据的 sheet 在此代码中称为 "TestData"。它应该是您项目中响应绰号 Sheets(1) 的那个，很可能又名 ThisWorkbook.Worksheets("Sheet1").