VBA - Script to search and replace values in rows between sheets based on criteria

[RobertHamberg]

I want ascript to search for the values in column A in sheet 1 and try to find a match in column A in Sheet 2. If a match is found I want the script to copy the values in column F-J in sheet 1 and add those values to column F-J in sheet 2 on the matching rows. Anyone able to help?

Sheet 1

A B C D E F G H I J 1 Name Owner Start End Time (H) Team R1 % R2 % 2 Test2 Owner2 2018-01-01 2018-12-31 200 Team2 Resurs2 100 0 0 3 Test3 Owner3 2018-01-01 2018-12-31 300 Team3 Resurs3 100 0 0 4 Test5 Owner5 2018-01-01 2018-12-31 500 Team5 Resurs5 100 0 0 5 Test6 Owner6 2018-01-01 2018-12-31 600 Team6 Resurs6 75 Resurs3 25 6 Test8 Owner8 2018-01-01 2018-12-31 800 Team8 Resurs8 50 Resurs7 50 7 Test10 Owner10 2018-01-01 2018-12-31 1 000 Team10 Resurs10 50 Resurs9 50 <tbody> </tbody>

<tbody>
</tbody>

Sheet 2

A B C D E F G H I J 1 Name Owner Start End Time (H) Team R1 % R2 % 2 Test1 Owner1 2018-01-01 2018-12-31 100 3 Test2 Owner2 2018-01-01 2018-12-31 200 4 Test3 Owner3 2018-01-01 2018-12-31 300 5 Test4 Owner4 2018-01-01 2018-12-31 400 6 Test5 Owner5 2018-01-01 2018-12-31 500 7 Test6 Owner6 2018-01-01 2018-12-31 600 8 Test7 Owner7 2018-01-01 2018-12-31 700 9 Test8 Owner8 2018-01-01 2018-12-31 800 10 Test9 Owner9 2018-01-01 2018-12-31 900 11 Test10 Owner10 2018-01-01 2018-12-31 1 000 <tbody> </tbody>

<tbody>
</tbody>

 

[RobertHamberg]

Will try that, thanks alot for the help. Much appriciated!

 

[RobertHamberg]

Problem is that rows with no match have all values in all columns removed besides column A

 

[Fluff]

Untested, but try this

Sub CopyCols()

   Dim Cl As Range
   Dim Sht1 As Worksheet
   Dim Sht2 As Worksheet
   
   Set Sht1 = Sheets("Sheet1")
   Set Sht2 = Sheets("Sheet2")
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Sht1.Range("A2", Sht1.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl
      Next Cl
      For Each Cl In Sht2.Range("A2", Sht2.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then .Item(Cl.Value).EntireRow.Copy Cl
      Next Cl
   End With

End Sub

 

[RobertHamberg]

Works like a charm, so thankfull for all the help you've provided!

Untested, but try this

Sub CopyCols()

   Dim Cl As Range
   Dim Sht1 As Worksheet
   Dim Sht2 As Worksheet
   
   Set Sht1 = Sheets("Sheet1")
   Set Sht2 = Sheets("Sheet2")
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Sht1.Range("A2", Sht1.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl
      Next Cl
      For Each Cl In Sht2.Range("A2", Sht2.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then .Item(Cl.Value).EntireRow.Copy Cl
      Next Cl
   End With

End Sub

 

[Fluff]

Glad we could help & thanks for the feedback