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 says Run time error '13':

Type mismatch

 

[tomleitch]

I think I know what is causing the error.

One of the lines being copied in has an empty cell in sheet 1 column F (date column).

If I delete that row I don't get the error when I run it again.

But if I run it with that row still pasted in then I get the error.

 

[Fluff]

Which line of code is highlighted when the error occurs?

Just noticed post#39

If you're getting a type mismatch, when you hit debug, a line of code should be highlighted.

 

[tomleitch]

It doesn't give me a debug option on this occasion (normally get one).... it just gives me a Runtime Error '13': Type Mismatch then option buttons are ok or help

 

[Fluff]

In that case try this

Sub CopyDataUnique()

         Dim Cl As Range
         Dim Ky As Variant
         Dim NxtRw As Long
         Dim Ws1 As Worksheet
         Dim Ws2 As Worksheet
         On Error GoTo Xit
10       Set Ws1 = Sheets("New")
20       Set Ws2 = Sheets("Master")
         
30       With CreateObject("scripting.dictionary")
40          For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
50             If Not .exists(Cl.Value) Then .Add Cl.Value, Array(Cl.Offset(, 4).Value, Cl.Offset(, 6).Value)
60          Next Cl
70          For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
80             If .exists(Cl.Value) Then
90                If trim(UCase(Cl.Offset(, 4).Value)) <> trim(UCase(.Item(Cl.Value)(0))) Then Cl.Offset(, 4).Value = .Item(Cl.Value)(0)
100               If CLng(Cl.Offset(, 5).Value) <> CLng(.Item(Cl.Value)(1)) Then Cl.Offset(, 5).Value = .Item(Cl.Value)(1)
110              .Remove (Cl.Value)
120            End If
130         Next Cl
140         NxtRw = Ws1.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
150         For Each Ky In .keys
160            Ws1.Range("A" & NxtRw).Value = Ky
170            Ws1.Range("E" & NxtRw).Resize(, 2).Value = .Item(Ky)
180            NxtRw = NxtRw + 1
190         Next Ky
200      End With
Exit Sub
Xit:
MsgBox Erl
End Sub

Hopefully you should get a msgbox with a number, what is the number.

 

[tomleitch]

It's giving me error on line 100

 

[Fluff]

Sounds like one of your dates isn't a date, or a blank cell isn't actually blank. Change the msgbox to

MsgBox Cl.Row & ", " & Cl.Value

This will tell you what the col A value is & what row on the copy to sheet is giving a problem.

 

[tomleitch]

Can't understand it, but it's just completely stopped giving me the error - and didn't change anything.

 

[tomleitch]

Fluff, I'm quite aware that I've taken up a fair bit of your time - but would you mind helping me do one more thing...

When it looks up column A and copy and paste I'd like to also make it paste from sheet 2 column F to 1 Column D (Only if the values are different)
and from Sheet 2 Column B to Sheet 1 column B (But only if Sheet 1 column B is blank).

Thanks,
Tom

 

[Fluff]

try

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 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
End Sub