我当前的代码将尝试使用 VBA 将基于列 A 重复名称的整行复制到其各自的工作表，如下所示。但它只适用于第一个重复的名称，而不适用于其余的名称。当我检查我的代码时，我意识到我的目标（在目标=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
使用字典作为起始行，使用另一个字典作为结束行。然后可以直接确定每个名称的重复行的范围并将其复制到新工作表中。
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