store rows in vba dictionary A1:D8 and check if cell value in column A matches unique key in column K if match then paste

Question

Dim Cell    As Range
    Dim Data    As Variant
    Dim Dict    As Object
    Dim Item    As Variant
    Dim Key     As Variant
    Dim Rng     As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet

        Set Wks = ThisWorkbook.activesheet

        Set RngBeg = Wks.Range("A1:D8")
        Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)

        If RngEnd.Row < RngBeg.Row Then Exit Sub

        Set Rng = Wks.Range(RngBeg, RngEnd)

        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare

            For Each Cell In Rng.Columns(1).Cells
                Key = Trim(Cell)
                Item = Cell.Resize(1, Rng.Columns.Count).Value

    With activesheet
        For Each Cell In .Range("k2", .Range("k" & Rows.Count).End(xlUp))
            If Dict.exists(Cl.Value) Then Cell.Offset(, 1).Value = Dic(Cell.Value)
        Next Cell
    End With

In column K I have values : 98,34,78,11 and in column A I have :98,98,98,11,34,78,78

The dictionary stores each row in col A:D

for example:

98,east,phone,address
98,west,mobile,na

and then checks if the first cell in A1: 98 matches with column K and if it does paste row A1:D1 next to row in column K corresponding to 98 and insert a row if there several matches i.e 3 98s in column A.

The problem occurs here where it is supposed to paste the values next to the unique keys ie 98 in column K but does not do so:

    With activesheet
        For Each Cell In .Range("k2", .Range("k" & Rows.Count).End(xlUp))
            If Dict.exists(Cell.Value) Then Cell.Offset(, 1).Value = Dic(Cell.Value)
        Next Cell
    End With

Could someone please suggest what is going wrong?

I have edited code referenced from here:

CDP1802 CDP1802 · Accepted Answer · 2020-03-14T14:47:29

Dictionary Keys must be unique so if you build it from column A then any previous values will be replaced as you scan down. Assuming column K values are unique then use that column to build the dictionary using cell as key and row number as value. Then by scanning column A the dictionary will give the target row for Col A:D to be copied to. It gets more complicated when adding rows because the dictionary has to be refreshed.

Sub match()

    'https://stackguides.com/questions/60681813/store-rows-in-vba-dictionary-a1d8-and-check-if-cell-value-in-column-a-matches-u

    Const COL_DICT = "K"
    Const COL_DATA = "A"
    Const COLS_COPY = 4

    Dim wb As Workbook, ws As Worksheet, i As Long
    Dim iRow As Long, iLastRow As Long, iLastDictRow As Long
    Dim iTargetRow As Long, rngTarget As Range
    Dim Dict As Object, sKey As String

    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet ' sheets("Sheet Name") would be better

    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare

    'build dictionary as lookup to row no
    iLastDictRow = ws.Range(COL_DICT & Rows.Count).End(xlUp).Row
    For iRow = 2 To iLastDictRow
        sKey = CStr(ws.Cells(iRow, COL_DICT))
        If Dict.exists(sKey) Then
            MsgBox "Duplicate key " & sKey & " at row " & iRow, vbCritical
            Exit Sub
        Else
            Dict.Add sKey, iRow
        End If
    Next

    ' scan down data
    iLastRow = ws.Range(COL_DATA & Rows.Count).End(xlUp).Row
    For iRow = 2 To iLastRow
        sKey = ws.Cells(iRow, COL_DATA)
        If Dict.exists(sKey) Then
            iTargetRow = Dict(sKey)
            Set rngTarget = ws.Cells(iTargetRow, COL_DICT)

            If rngTarget.Offset(0, 1).Value = "" Then

               ws.Cells(iRow, 1).Resize(1, COLS_COPY).Copy rngTarget

            Else

                ' add row
                rngTarget.Offset(1, 0).Resize(1, COLS_COPY).Insert _
                   Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                ws.Cells(iRow, 1).Resize(1, COLS_COPY).Copy rngTarget.Offset(1, 0)

                ' rebuild dictionary after added row
                iLastDictRow = iLastDictRow + 1
                For i = 2 To iLastDictRow
                    sKey = CStr(ws.Cells(i, COL_DICT))
                    Dict(sKey) = i
                Next

            End If
        End If
    Next

    MsgBox iLastRow - 1 & " rows scanned in col " & COL_DATA, vbInformation, "Finished"

End Sub

store rows in vba dictionary A1:D8 and check if cell value in column A matches unique key in column K if match then paste

1 Answers