Matching Then Copy/Pasting in VBA

[Kramer328]

Hey everyone,

I am very new to VBA Programming so let me know if anyone needs more information. I am trying to write a VBA macro that will search columns F, H, and J in Sheet1 of my workbook and compare those values to column A of Sheet2. If there is a match, I would like to copy the values on Sheet2 that are 3 cells over (to the right) from the match on Sheet2 and paste that value one cell over (to the right) to the matching value in Sheet1. For example, if the first table is 'Sheet1' and the second table is 'Sheet2', I would like the result to look like the third table. Any help would be greatly appreciated. Thanks!

[TABLE="width: 500"]
<tbody>[TR]
[TD]SHEET1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]Find1[/TD]
[TD][/TD]
[TD]Find2[/TD]
[TD][/TD]
[TD]Find3[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 500"]
<tbody>[TR]
[TD]SHEET2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]Find1[/TD]
[TD][/TD]
[TD][/TD]
[TD]1.5
[/TD]
[/TR]
[TR]
[TD]Find2[/TD]
[TD][/TD]
[TD][/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Find3[/TD]
[TD][/TD]
[TD][/TD]
[TD]2.5[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 500"]
<tbody>[TR]
[TD]SHEET1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]Find1[/TD]
[TD]1.5[/TD]
[TD]Find2[/TD]
[TD]2[/TD]
[TD]Find3[/TD]
[TD]2.5[/TD]
[/TR]
</tbody>[/TABLE]

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub GetValues()
   Dim Cl As Range
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 3).Value
      Next Cl
      For Each Cl In Intersect(Ws1.UsedRange, Ws1.Range("F:F,H:H,J:J"))
         Cl.Offset(, 1).Value = .Item(Cl.Value)
      Next Cl
   End With
End Sub

 

[Kramer328]

Hey Fluff Thanks so much this is working great. The only problem I am having is that when the macro finishes, the values in cells G1, I1, K1 are cleared and I can't figure out why.

 

[Kramer328]

I should be more specific. The first row in my worksheet (Sheet1) contains headers so they don't match any values in Sheet2. However, the values in G1, I1 and K1 are cleared after running the macro.

 

[Fluff]

Ok, as long as you don't have any blank cells in sheet2, try

Sub GetValues()
   Dim Cl As Range
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Pcode")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         .Item(Cl.Value) = Cl.Offset(, 3).Value
      Next Cl
      For Each Cl In Intersect(Ws1.UsedRange[COLOR=#ff0000].Offset(1)[/COLOR], Ws1.Range("F:F,H:H,J:J"))
         Cl.Offset(, 1).Value = .Item(Cl.Value)
      Next Cl
   End With
End Sub