Home » excel » excel – How to express my dictionary details as array in VBA?

excel – How to express my dictionary details as array in VBA?

Posted by: admin May 14, 2020 Leave a comment


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.

enter image description here

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..

enter image description here

How to&Answers:

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

enter image description here


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
           dictFirstRow.Add sKey, irow
           dictLastRow.Add sKey, irow
        End If

    ' 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

    MsgBox "Done"

End Sub