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

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

Solution

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