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

 

[tomleitch]

It works almost perfectly..... the only thing that its not doing is that it is updating the column B if it is different.

The column B I'd like to only copy data across if the destination cell is blank - e.g. if someone has edited the text in the cell then I don't want it to be overwritten

 

[Fluff]

Make this change

            If Cl.Offset(, 1).Value = "" Then Cl.Offset(, 1).Value = .Item(Cl.Value)(0)

 

[tomleitch]

Make this change

            If Cl.Offset(, 1).Value = "" Then Cl.Offset(, 1).Value = .Item(Cl.Value)(0)

Sorry Fluff, I can't work out which line to paste it in to... can you help, I've currently got this:

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("OPS PLANNER")
   Set Ws2 = Sheets("UPDATE TOOL")
   
   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, Array(Cl.Offset(, 1).Value, Cl.Offset(, 4).Value, Cl.Offset(, 5).Value, Cl.Offset(, 6).Value)
      Next Cl
      For Each Cl In Ws1.Range("A10", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
            If Trim(UCase(Cl.Offset(, 1).Value)) <> Trim(UCase(.Item(Cl.Value)(0))) Then Cl.Offset(, 1).Value = .Item(Cl.Value)(0)
            If Trim(UCase(Cl.Offset(, 4).Value)) <> Trim(UCase(.Item(Cl.Value)(1))) Then Cl.Offset(, 4).Value = .Item(Cl.Value)(1)
            If Trim(UCase(Cl.Offset(, 3).Value)) <> Trim(UCase(.Item(Cl.Value)(2))) Then Cl.Offset(, 3).Value = .Item(Cl.Value)(2)
            If CLng(Cl.Offset(, 5).Value) <> CLng(.Item(Cl.Value)(3)) Then Cl.Offset(, 5).Value = .Item(Cl.Value)(3)
           .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
        Ws1.Range("E" & NxtRw).Resize(, 2).Value = .Item(Ky)
         NxtRw = NxtRw + 1
      Next Ky
    End With

I promise this will be the last I ask of you!, really appreciate all your help.

 

[Fluff]

Here you go

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("New")
   Set Ws2 = Sheets("Master")
   
   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, Array(Cl.Offset(, 1).Value, Cl.Offset(, 4).Value, Cl.Offset(, 5).Value, Cl.Offset(, 6).Value)
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
            If Cl.Offset(, 1).Value = "" Then Cl.Offset(, 1).Value = .Item(Cl.Value)(0)
            If trim(UCase(Cl.Offset(, 4).Value)) <> trim(UCase(.Item(Cl.Value)(1))) Then Cl.Offset(, 4).Value = .Item(Cl.Value)(1)
            If trim(UCase(Cl.Offset(, 3).Value)) <> trim(UCase(.Item(Cl.Value)(2))) Then Cl.Offset(, 3).Value = .Item(Cl.Value)(2)
            If CLng(Cl.Offset(, 5).Value) <> CLng(.Item(Cl.Value)(3)) Then Cl.Offset(, 5).Value = .Item(Cl.Value)(3)
           .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
         Ws1.Range("E" & NxtRw).Resize(, 2).Value = .Item(Ky)
         NxtRw = NxtRw + 1
      Next Ky
   End With
End Sub

 

[tomleitch]

Thanks so much for all your help and patience! works a treat. Cheers.

 

[Fluff]

Glad to help & thanks for the feedback

 

[tomleitch]

Hi Fluff.

Wondering if you would mind helping again with this.

Where new data is being imported and column A doesn't exist in the destination sheet - I have changed the code so that it is adding in column A from the source sheet and also column B to it... so I have this section of code:

 Next Cl
      NxtRw = Ws1.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      For Each Ky In .keys
         Ws1.Range("A" & NxtRw).Value = Ky
         Ws1.Range("B" & NxtRw).Resize(, 1).Value = .Item(Ky)
         NxtRw = NxtRw + 1
      Next Ky
   End With

So that gives me both the Column A and B data that I want in ws1

What I also want it to do is add ws2 col E to ws1 col E, ws2 col F to ws1 col D and ws2 G to ws2 F.


Is that possible?



The whole code I have is this:

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("OPS PLANNER")
   Set Ws2 = Sheets("UPDATE TOOL")
   
   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, Array(Cl.Offset(, 1).Value, Cl.Offset(, 4).Value, Cl.Offset(, 5).Value, Cl.Offset(, 6).Value)
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
            If Cl.Offset(, 1).Value = "" Then Cl.Offset(, 1).Value = .Item(Cl.Value)(0)
            If Trim(UCase(Cl.Offset(, 4).Value)) <> Trim(UCase(.Item(Cl.Value)(1))) Then Cl.Offset(, 4).Value = .Item(Cl.Value)(1)
            If Trim(UCase(Cl.Offset(, 3).Value)) <> Trim(UCase(.Item(Cl.Value)(2))) Then Cl.Offset(, 3).Value = .Item(Cl.Value)(2)
            If CLng(Cl.Offset(, 5).Value) <> CLng(.Item(Cl.Value)(3)) Then Cl.Offset(, 5).Value = .Item(Cl.Value)(3)
           .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
         Ws1.Range("B" & NxtRw).Resize(, 1).Value = .Item(Ky)
         NxtRw = NxtRw + 1
      Next Ky
   End With
End Sub

Any help or pointers appreciated,

Thanks
Tom

 

[Fluff]

Is this what you want?

      For Each Ky In .keys
         Ws1.Range("A" & NxtRw).Value = Ky
         Ws1.Range("B" & NxtRw).Value = .Item(Ky)(0)
         Ws1.Range("E" & NxtRw).Value = .Item(Ky)(1)
         Ws1.Range("D" & NxtRw).Value = .Item(Ky)(2)
         Ws1.Range("F" & NxtRw).Value = .Item(Ky)(3)
         NxtRw = NxtRw + 1
      Next Ky

 

[tomleitch]

Yep, that's it! Once again a huge help, thanks so much!

 

[Fluff]

Glad to help & thanks for the feedback