Tag: program

My current code is used to copy entire rows based on column A duplicate name in their respective worksheet as shown below. But it only works for the duplicate first name, but not for the rest. When I check my code, I realized that my target (at for target = Lbound to Ubound part) is always 0, so I was wondering why it's always 0 in this case.

Below is my code (sorry if it's too long)

Sub cb()

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)

'Key here consists of the list of Names that are in the dictionary
'how do i extract the list of Names stored in Key so that i can put them into the array shown below?


v = dict.Keys 'put the keys into an array (seems redundant to me)

'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 'why is target 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