问题
My current code will attempt to copy entire rows based on the column A duplicated name to its respective worksheet using VBA as shown below. But it only works for the 1st duplicated name but not the rest. When i review my code, i realised that my target(at the part for target=Lbound to Ubound part) is always 0 so i was wondering why is it always 0 in this case? Because it suppose to be ranging from 0 to 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
Main worksheet
In the case of duplicated John name:
In the case of duplicated Alice name
Updated code:
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
回答1:
Use a dictionary for the start row and another for the end row. It is then straightforward to determine the range of duplicate rows for each name and copy them to a new 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
回答2:
I couldn't find a mistake because I didn't want to set up the workbook that would enable me to test your code thoroughly. However, I did read through your code and found that you were very lax on declaring variables. I suggest you enter Option Explicit at the top of your code.
To call a Key a "Key" is asking for trouble. Best practice suggests that you don't use VBA key words as variable names. In the context of your code, For Each Key In Dict.Keys requires Key to be a variant. Being undeclared would make it a variant by default but if it's also a word VBA reserves for its own use confusion might arise.
Another idea is that you might have put a break point on For Target = LBound(v) To UBound(v) - 1. When the code stops there Target will be zero because the line hasn't executed yet. But after the first loop execution will not return to this line. So you might have missed Target taking on a value and the error might be elsewhere. Make sure you place the break point on the first line after the For statement. You might also add Debug.Print LBound(v), UBound(v) before the For statement or check these values in the Locals window.
Below is the section of the code where I added several variable declarations and made an amendment to the code that creates and names the new sheets.
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
回答3:
John, I spent an hour working my way through your code - correcting and commenting. I got a real good feeling of how confidence escaped from your mind as you went into the last third of the code. The same thing happened to me. I saw, as you probably did, that the concept was so far off the mark that it is very hard to salvage. So I wrote code that probably does what you want. Please try it.
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
The code doesn't use a dictionary. That's why it is much shorter and much more efficient, too. It just sorts the data directly to different sheets based on what it finds in column A. There is no limit to the number of sheets you might need.
Observe that the sheet on which I had the data is called "TestData" in this code. It should be the one in your project that responded to the moniker Sheets(1), most likely aka ThisWorkbook.Worksheets("Sheet1").
来源：https://stackoverflow.com/questions/60878328/how-to-copy-entire-rows-based-on-column-a-duplicated-name-to-its-respective-work