Add offset to my macro

[emukiss10]

Hello Guys!

I need little help with my script. It compares A2:A from two Sheets and if match it is copying cell F of one shhet to cell K of the other.
It works fine But...

I want to compare not only A2:A but A2:A and Offset(,3) to Offset(,4)

something like

Kl.Value & Kl.Offset(,3) 
 to 
K2.Value & K2.Offset(,4)

My working Macro

    Dim Kl As Range, K2 As Range
    Dim ValK As Variant, ValK2 As Variant
    Dim dict As Scripting.Dictionary, dict2 As Scripting.Dictionary
    
    Set dict = New Scripting.Dictionary
    dict.CompareMode = vbTextCompare
    Set dict2 = New Scripting.Dictionary
    dict2.CompareMode = vbTextCompare
 
    With dict
        For Each Kl In Sheets(1).Range("A2", Sheets(1).Range("A" & Rows.count).End(xlUp))
            If Not .Exists(Kl.Value) Then .Add Kl.Value, Kl.row
        Next Kl
    End With
    With dict2
        For Each K2 In Sheets(2).Range("A2", Sheets(2).Range("A" & Rows.count).End(xlUp))
            If Not .Exists(K2.Value) Then .Add K2.Value, K2.row
        Next K2
    End With
    For Each ValK In dict.keys
        For Each ValK2 In dict2.keys
            If ValK Like ValK2 Then
                With Sheets(1)
                    .Cells(dict(ValK), "K").Value = Sheets(2).Range("F" & dict2(ValK2))
                End With
            End If
        Next ValK2
    Next ValK

Or mayby it can be done better (faster - I have over 1M rows n one sheet and aboput 50K i second)

Best Regards!
W.

 

[Fluff]

How about

Sub Comparedata()

   Dim Cl As Range
   Dim v1 As String
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   
   Set Ws1 = Sheets(1)
   Set Ws2 = Sheets(2)
   With CreateObject("Scripting.dictionary")
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         v1 = Cl.Value & Cl.Offset(, 3).Value
         If Not .exists(v1) Then .Add v1, Cl.Offset(, 10).Value
      Next Cl
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         v1 = Cl.Value & Cl.Offset(, 4).Value
         If .exists(v1) Then Cl.Offset(, 5).Value = .Item(v1)
      Next Cl
   End With
End Sub

 

[emukiss10]

Hmm... I might explained it wrong..

ex.

IF Sheets(2).Range("A500") is found in Sheets(1).Range("A245") And Sheets(2).Range("D500") is match with Sheets(1).Range("E245")
Than
copy Sheets(2).Range("F500") to Sheets(1).Range("K245")

Im sorry Fluff for my engilsh. Explaining is sometimes tough.

 

[Fluff]

My fault, I misread your code. Try

Sub Comparedata()

   Dim Cl As Range
   Dim v1 As String
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   
   Set Ws1 = Sheets(1)
   Set Ws2 = Sheets(2)
   With CreateObject("Scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         v1 = Cl.Value & Cl.Offset(, 3).Value
         If Not .exists(v1) Then .Add v1, Cl.Offset(, 5).Value
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         v1 = Cl.Value & Cl.Offset(, 4).Value
         If .exists(v1) Then Cl.Offset(, 10).Value = .Item(v1)
      Next Cl
   End With
End Sub

 

[emukiss10]

Perfect.

Just for kicks - can it copy lets say more than one value? Like from any two or more columns? F and G for exampe?

 

[Fluff]

Yup

Sub Comparedata()

   Dim Cl As Range
   Dim v1 As String
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   
   Set Ws1 = Sheets(1)
   Set Ws2 = Sheets(2)
   With CreateObject("Scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         v1 = Cl.Value & Cl.Offset(, 3).Value
         If Not .exists(v1) Then .Add v1, Cl.Offset(, 5).Resize(, 2).Value
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         v1 = Cl.Value & Cl.Offset(, 4).Value
         If .exists(v1) Then Cl.Offset(, 10).Resize(, 2).Value = .Item(v1)
      Next Cl
   End With
End Sub

 

[emukiss10]

Maaaan... Please clone yourself.. ok?

 

[Fluff]

Glad to help & thanks for the feedback