This is the follow up of this question that i have asked previously How do i find the last row index of each duplicates within the same column?. Currently i am trying to extract each of the duplicated names that i have already found, stored under the Key of the dictionary. But how do i extract and express them in the form of array using the Key that i have found previously? Because ultimately i want to use the size of the array as one of the condition to copy the entire column of duplicated names into another worksheet but i couldn’t express the Key here such that they have an array size.
edit: What i mean by extract each of the duplicated name is where the arr size should be 4 as arr= (“John”,”trump”,”alice”,”sarah”) if i managed to extract them from dict to array
Dim target as long For Target = LBound(Arr) To UBound(Arr)
picture of the dictionary details that checks for duplicated name
Debug.Print Key, Dict(Key), Rng.Address
‘dict(key) refers to the lastrow index of duplicated names, Key refers to the name of duplicated name, Rng.address refers to the range where each duplicated name lies.
the purpose of finding array in the form of arr=(“John”,”trump”,”alice”,”sarah”)
Because i ultimately, i wanted to copy and paste the entire duplicate into different worksheets for example, entire row that consists of the name john into john worksheet, entire row that consists of the name sarah into sarah worksheet. Hence, my plan layout is to find their row index, then use arrays to check whether their name exists in arr= (“john”,”sarah”,”alice”,”trump”), and if they exist, proceed to copy and paste them into their respective worksheet. Hence, after i got my rowindex from dict, i tried to integrate them into the arr parts which leads me to this problem..
Perhaps this is what you’re after, although I don’t see why you need an array.
Sub x() Dim r As Range, dict As Object, i As Long, v Set dict = CreateObject("Scripting.Dictionary") For Each r In Range("A1:A9") dict(r.Value) = r.Address Next r v = dict.keys 'put the keys into an array (seems redundant to me) For i = LBound(v) To UBound(v) MsgBox v(i) Next i End Sub
To fill a column with the keys use transpose.
Sub demo() Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") dict.Add "A", 1 dict.Add "B", 1 dict.Add "C", 1 Sheets("Sheet1").Range("A1").Resize(dict.Count, 1) = WorksheetFunction.Transpose(dict.keys) End Sub
There is no need to copy the duplicate names from the dictionary keys into an array and then use the array to check if a value is a duplicate, the dictionary exists(name) method does that for you.
By using a dictionary for the start row and another for the end row, it is straightforward to determine the range of duplicate rows for each name and copy that range to a new sheet without rescanning column A checking if the cell value exist in an array of ‘duplicate names’.
Option Explicit 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