Matching data between two sheets and cutting and pasting

[tomleitch]

I'm looking for some help/pointers with some vba (which I'm not great with).

What I'm trying to do is this....


Column A on worksheet 1 contains "Item Number"

Column A on worksheet 2 also contains "Item Number"


I want to find matching ones in worksheet 2 and cut and paste the data from worksheet 2 that row column E to the matching row column E on worksheet 1... if that makes sense. With the same match I also want to cut column G on worksheet 2 to column F on worksheet 1.

Any help much appreciated.

Thanks,
Tom

 

[Fluff]

Are the item # unique, or can the same item # appear multiple times on either sheet?

 

[tomleitch]

They are identification numbers, so will be unique

 

[Fluff]

Try

Sub CopyDataUnique()

   Dim Cl As Range
   Dim Ws1 As Worksheet
   Dim 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))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
           Union(.Item(Cl.Value).Offset(, 4), .Item(Cl.Value).Offset(, 6)).Copy Cl.Offset(, 4)
         End If
      Next Cl
   End With
End Sub

 

[tomleitch]

This works great, and I very much appreciate your help.

I am wondering if is possible to do one other thing...

I would like to look in column A on sheet 2 for items that are not listed in column B on sheet 2 and then copy and paste them into sheet 1 below the bottom row.

Is this possible?

Thanks,
Tom

 

[Fluff]

How many items are we talking about, could you have 5,000+ items on sheet2 that are not in sheet1?

 

[tomleitch]

No, at a rough guess - very most would be 100, more likely usually around 20

 

[Fluff]

In that case try

Sub CopyDataUnique()

   Dim Cl As Range
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet2")
   Set Ws2 = Sheets("data")
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
           Union(.Item(Cl.Value).Offset(, 4), .Item(Cl.Value).Offset(, 6)).Copy Cl.Offset(, 4)
           .Remove (Cl.Value)
         End If
      Next Cl
      Ws1.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Count) = Application.Transpose(.keys)
   End With
End Sub

 

[tomleitch]

That looks to work really well - is it possible also to copy the columns as per the first items from the other columns....

"cut and paste the data from worksheet 2 that row column E to the matching row column E on worksheet 1... if that makes sense. With the same match I also want to cut column G on worksheet 2 to column F on worksheet 1."

thanks again for your time

 

[Fluff]

How about

Sub CopyDataUnique()

   Dim Cl As Range
   Dim Ky As Variant
   Dim NxtRw As Long
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet2")
   Set Ws2 = Sheets("data")
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
           Union(.Item(Cl.Value).Offset(, 4), .Item(Cl.Value).Offset(, 6)).Copy Cl.Offset(, 4)
           .Remove (Cl.Value)
         End If
      Next Cl
      NxtRw = Ws1.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      For Each Ky In .keys
         Ws1.Range("A" & NxtRw).Value = Ky
         Union(.Item(Ky).Offset(, 4), .Item(Ky).Offset(, 6)).Copy Ws1.Range("E" & NxtRw)
         NxtRw = NxtRw + 1
      Next Ky
   End With
End Sub