Custom VBA Dictionary Solution

[Streetsteps]

Searching for a custom VBA dictionary code, for a massive workbook, containing two worksheets, sheet1 (Release) containing +40K rows, sheet 2 (Resource) containing +185k rows. I realize that any VBA macro will take a long time to execute this command–given the amount of data, that’s okay with me as long as it is functional. Any help would be greatly appreciated, I have spent months on various forums looking for a solution, and nothing quite works.

I attached images of a mock template, I created with only a few titles–to see if VBA macro is even possible to accomplish the task below. (Happy to email or DM template - if that is possible).

Ideally looking for the VBA code to focus only when the Releases worksheet Column H designated ‘Exclusive License.' [This cuts down the # of rows the macro would search by 70%].

Then isolate matches found in two cells within both worksheets, respectively Column B and C.

If an exact match, then the information in three columns of the Releases worksheet Columns H – J, is copied and replace info in the Resources worksheet of Columns H-J.

Finally, the macro should move onto the next "Exclusive License" row, repeat the command, until complete.

Latest VBA Error: Runtime Error “1004”
Sub Plzwork()
Dim Cl As Range
Dim Dic As Object

Set Dic = CreateObject("scripting.dictionary")
With Sheets("Release")
For Each Cl In .Range("$B:$C", .Range("$B:$C" & Rows.Count).End(xlUp))
Dic(Cl.Value) = Array(Cl, Cl.Offset(, 1).Value)
Next Cl
End With
With Sheets("Resources")
For Each Cl In .Range("$I:$K", .Range("$I:$K" & Rows.Count).End(xlUp))
If Dic.Exists(Cl.Value) Then
Cl.Offset(, 1).Value = Dic(Cl.Value)(1)
Dic(Cl.Value)(0).Interior.Color = vbRed
End If
Next Cl
End With
End Sub

 

[BSALV]

you're assigning your range wrong, for example, starting in B1 until last B-cell

For Each Cl In .Range("$B1:$B" & .Range("$B" & Rows.Count).End(xlUp).Row).Cells

you can share a link to your file with CTRL+K (on OneDrive,google, ...)

 

[Streetsteps]

Thanks Bslv for your response, it should be noted, that I am clearly a newbie/bad at VBA macros. That said, I went in and attempted to revise the code. Run-time Error '91'
Object Variable or with Block Variable Not Set.

Sub Plzwork()

Dim wk As Worksheet
For Each ws In Worksheets
Set ws = ThisWorkbook.Worksheets("Release")
Set ws = ThisWorkbook.Worksheets("Resource")

Set Dic = CreateObject("scripting.dictionary")

With Sheets("Release")
For Each C1 In wk.Range("$B1:$B" & .Range("$B" & Rows.Count).End(xlUp).Row).Cells
If oDic.Exists(Cl.Value) Then
Cl.Offset(, 1).Value = Dic(Cl.Value)(1)
Dic(Cl.Value) = Array(Cl, Cl.Offset(, 1).Value)
End If
Next C1

For Each C2 In wk.Range("$C1:$C" & .Range("$C" & Rows.Count).End(xlUp).Row).Cells
If oDic.Exists(C2.Value) Then
C2.Offset(, 1).Value = Dic(C2.Value)(1)
Dic(C2.Value) = Array(C2, C2.Offset(, 1).Value)
End If
Next C2
End With

With Sheets("Resources")
For Each C3 In wk.Range("$I1:$I" & .Range("$I" & Rows.Count).End(xlUp).Row).Cells
If oDic.Exists(C3.Value) Then
C3.Offset(, 1).Value = Dic(C3.Value)(1)
Dic(C3.Value) = Array(C3, C3.Offset(, 1).Value)
End If
Next C3
For Each C4 In wk.Range("$J1:$J" & .Range("$J" & Rows.Count).End(xlUp).Row).Cells
If oDic.Exists(C4.Value) Then
C4.Offset(, 1).Value = Dic(C4.Value)(1)
Dic(C4.Value) = Array(C4, C4.Offset(, 1).Value)
End If
Next C4
For Each C5 In wk.Range("$K1:$K" & .Range("$K" & Rows.Count).End(xlUp).Row).Cells
If oDic.Exists(C5.Value) Then
C5.Offset(, 1).Value = Dic(C5.Value)(1)
Dic(C5.Value) = Array(C5, C5.Offset(, 1).Value)
End If
Next C5
End With
Next
End Sub

I have uploaded the as suggested Mock Template

 

[BSALV]

most of the errors are spelling mistakes !
Now, it's working, but you never add a record to the dictionary, i didn't understand, what you're trying to do !mock

 

[Streetsteps]

Thank you, I appreciate your patience with me and also for the revised template.

I'm just trying to transfer from the Release worksheet, info from Columns H-J 'related to Exclusive Licenses', over to the Resource worksheets Columns H-J, as they are exact matches [I Highlighted the cells in your revised !Mock. ]

 

[BSALV]

Mock2

Sub CollectData()

     t = Timer

     Application.ScreenUpdating = False
     Set dict = CreateObject("scripting.dictionary")

     Set c1 = Sheets("release").Range("A1").CurrentRegion
     a = c1.Value2   'read data to an array to speed up everything
     For i = 2 To UBound(a)     'loop through all data
          If i Mod 1000 = 0 Then Application.StatusBar = "Release 1 " & Format(i, "#,###") & Format(UBound(a), "#,###"): DoEvents     'show progress on the statusbar
          If StrComp(a(i, 7), "Exclusive License", vbTextCompare) = 0 Then     'rights type
               dict("REL-" & a(i, 3)) = Array(a(i, 8), a(i, 9), a(i, 10))     'add 3 elements to dictionary with "REL-" & UPC as key
          End If
     Next

     Set c2 = Sheets("resource").Range("A1").CurrentRegion
     b = c2.Value2   'read data to an array to speed up everything
     For i = 2 To UBound(b)     'loop through all data
          If i Mod 1000 = 0 Then Application.StatusBar = "Release " & Format(i, "#,###") & Format(UBound(b), "#,###"): DoEvents
          If StrComp(b(i, 8), "Exclusive License", vbTextCompare) = 0 Then     'rights type
               If dict.exists("REL-" & b(i, 3)) Then
                    With c2(i, 15).Resize(, 3)     'in columns O-Q
                         .Value = dict("REL-" & a(i, 3))
                         .Interior.ColorIndex = 4
                    End With
                    dict("RES-" & b(i, 3)) = Array(b(i, 9), b(i, 10), b(i, 11))     'add this to the dictionary with key "RES-"  & UPC
               End If
          End If
     Next

     Set c = Sheets("resource").Range("A1").CurrentRegion
     For i = 2 To UBound(a)     'loop through all data
          If i Mod 1000 = 0 Then Application.StatusBar = "Release 2 " & Format(i, "#,###") & Format(UBound(a), "#,###"): DoEvents

          If StrComp(a(i, 7), "Exclusive License", vbTextCompare) = 0 Then     'rights type
               If dict.exists("RES-" & a(i, 3)) Then
                    With c1(i, 15).Resize(, 3)
                         .Value = dict("RES-" & a(i, 3))
                         .Interior.ColorIndex = 4
                    End With
               End If
          End If
     Next
     Application.StatusBar = ""

     MsgBox "done in " & Format(Timer - t, "0.00\s")
End Sub

 

[Streetsteps]

BSALV, you went above and beyond my request. The code worked beautifully. You explained each step, so that I can learn how it works, and even provided a Msg Box, to tell me how long the code would execute.

Thank you so much, extremely grateful!

BSALV​