How to copy entire rows based on column A duplicated name to its respective worksheet in VBA?

Question

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

Answer 1

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

Answer 2

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

Answer 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") .