VBA to Compare two different worksheets and copy missing rows

[cscotty]

Hello All.

I've been wrecking my brain for the past few days on how to write this vba script but it just wont come to me.

I have two worksheets in the same workbook. Sheet1 and Sheet2.

Sheet1 is consistently updated with new information and made available via Data Query . Sheet2 obtains its data from Sheet1, but Sheet2 is updated by my team. When Sheet1 is updated, it will contain the rows has already been copied to sheet 2. Therefore, I would like some help with a vba script that will compare a single column in Sheet1 (Column A) with a single column in Sheet2 (Column A). If the value does not exist, then I would like to copy specific cells from Sheet1 to Sheet2, for example, Columns A, C, E).

Unfortunately the code I have so far is pretty messy (I'm still learning vba) but if any help can be provided I'd appreciate it. I have attached a picture of the expected results.

Thanks so much in advance for your help!

Sub CompareTwoColumns()
      Dim col1 As Range
      Dim col2 As Range
      Dim prod1 As String
      Dim prod2 As String
      Dim lr As Long
      Dim incol1 As Variant
      Dim incol2 As Variant
      Dim r As Long
      Dim ws1 As Worksheet
      Dim ws2 As Worksheet
      
      Set ws1 = Sheets("Sheet1")
      Set ws2 = Sheets("Sheet2")
      Set col1 = Sheets("Sheet1").Columns("A")
      Set col2 = Sheets("Sheet2").Columns("A")
      
    lr = Columns("B:C").SpecialCells(xlCellTypeLastCell).Row

'Select first empty cell in column 2
With ws2

For Each cell In ws2.Columns(2).Cells
        If IsEmpty(cell) = True Then cell.Select: Exit For
    Next cell

End With

'Set empty cell variable
Dim nextcell As Range
Set nextcell = ActiveCell

 With ws1
      For r = 2 To lr
          prod1 = Cells(r, col1.Column).Value
          prod2 = Cells(r, col2.Column).Value
   
          'check if prod1 is in col2
          If prod1 <> "" Then
              Set incol2 = col2.Find(prod1)
              If incol2 Is Nothing Then
                  'Cells(r, col1.Column).Interior.Color = vbYellow
                .Range(.Range("A2"), .Columns("A").Cells(.UsedRange.Rows(.UsedRange.Rows.Count).Row)).copy Destination:=nextcell
                .Range(.Range("C2"), .Columns("C").Cells(.UsedRange.Rows(.UsedRange.Rows.Count).Row)).copy Destination:=nextcell.Offset(0, 2)
                .Range(.Range("E2"), .Columns("E").Cells(.UsedRange.Rows(.UsedRange.Rows.Count).Row)).copy Destination:=nextcell.Offset(0, 4)
              End If
          End If
   
Next
End With
End Sub

 

[LazyBug]

Hello!
How about

Sub cscotty()
Dim r, d, i&, lr&, f
    With Worksheets("Sheet1")
        r = .Range("A2").CurrentRegion
        Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(r)
                d.Item(r(i, 1)) = Array(r(i, 3), r(i, 5))
            Next i
    End With
    
    With Worksheets("Sheet2")
        lr = .UsedRange.Row - 1 + .UsedRange.Rows.Count
        For Each r In d.keys
            Set f = .Columns(1).Find(r)
                If f Is Nothing Then
                    .Cells(lr + 1, 1) = r: .Cells(lr + 1, 3) = d.Item(r)(0): .Cells(lr + 1, 5) = d.Item(r)(1)
                    lr = lr + 1
                End If
        Next r
    End With
End Sub

 

[cscotty]

Hello!
How about

Sub cscotty()
Dim r, d, i&, lr&, f
    With Worksheets("Sheet1")
        r = .Range("A2").CurrentRegion
        Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(r)
                d.Item(r(i, 1)) = Array(r(i, 3), r(i, 5))
            Next i
    End With
   
    With Worksheets("Sheet2")
        lr = .UsedRange.Row - 1 + .UsedRange.Rows.Count
        For Each r In d.keys
            Set f = .Columns(1).Find(r)
                If f Is Nothing Then
                    .Cells(lr + 1, 1) = r: .Cells(lr + 1, 3) = d.Item(r)(0): .Cells(lr + 1, 5) = d.Item(r)(1)
                    lr = lr + 1
                End If
        Next r
    End With
End Sub

Thanks LazyBug! Will give this a try and report back.

 

[LazyBug]

Will give this a try and report back.

Of course! Write here if you need more help or if you have any questions.

 

[cscotty]

Hello!
How about

Sub cscotty()
Dim r, d, i&, lr&, f
    With Worksheets("Sheet1")
        r = .Range("A2").CurrentRegion
        Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(r)
                d.Item(r(i, 1)) = Array(r(i, 3), r(i, 5))
            Next i
    End With
   
    With Worksheets("Sheet2")
        lr = .UsedRange.Row - 1 + .UsedRange.Rows.Count
        For Each r In d.keys
            Set f = .Columns(1).Find(r)
                If f Is Nothing Then
                    .Cells(lr + 1, 1) = r: .Cells(lr + 1, 3) = d.Item(r)(0): .Cells(lr + 1, 5) = d.Item(r)(1)
                    lr = lr + 1
                End If
        Next r
    End With
End Sub

Of course! Write here if you need more help or if you have any questions.

Hi LazyBug,

Thank you so much, the code works great for the example I provided. I'm trying to adapt it to my real application but I'm having a little trouble. I'm trying to extend the range of the array since I have exactly 7 columns of content to copy over (instead of the three in the example).

Would you please comment out this part of the code, as I'm trying to understand how to expand the range of the array to cover the columns A:G:

Dim r, d, i&, lr&, f
    With Worksheets("Sheet1")
        r = .Range("A2").CurrentRegion
        Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(r)
                d.Item(r(i, 1)) = Array(r(i, 3), r(i, 5))
            Next i
    End With

Thanks so much for your help!

 

[cscotty]

Hi LazyBug,

Thank you so much, the code works great for the example I provided. I'm trying to adapt it to my real application but I'm having a little trouble. I'm trying to extend the range of the array since I have exactly 7 columns of content to copy over (instead of the three in the example).

Would you please comment out this part of the code, as I'm trying to understand how to expand the range of the array to cover the columns A:G:

Dim r, d, i&, lr&, f
    With Worksheets("Sheet1")
        r = .Range("A2").CurrentRegion
        Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(r)
                d.Item(r(i, 1)) = Array(r(i, 3), r(i, 5))
            Next i
    End With

Thanks so much for your help!

Ok, I figured out how to extend the array range and copy the relevant columns over to the appropriate column in worksheet 2:

Sub CompareTwoColumns()

Dim ws44 As Worksheet
Dim ws43 As Worksheet
Set ws44 = Sheets("SAMq")
Set ws43 = Sheets("TEST")
Dim r, d, i&, lr&, f
    With ws44
        r = .Range("A2").CurrentRegion
        Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(r)
                d.Item(r(i, 1)) = Array(r(i, 2), r(i, 3), r(i, 5), r(i, 6), r(i, 7), r(i, 9))
            Next i
    End With
    
    With ws43
        lr = .UsedRange.Row - 1 + .UsedRange.Rows.Count
        For Each r In d.keys
            Set f = .Columns(1).Find(r)
                If f Is Nothing Then
                    .Cells(lr + 1, 2) = r: .Cells(lr + 1, 3) = d.Item(r)(0): .Cells(lr + 1, 4) = d.Item(r)(1)
                    .Cells(lr + 1, 6) = d.Item(r)(2): .Cells(lr + 1, 7) = d.Item(r)(3): .Cells(lr + 1, 8) = d.Item(r)(4)
                    .Cells(lr + 1, 9) = d.Item(r)(5)
                    lr = lr + 1
                End If
        Next r
    End With

End Sub

With my new code, I notice that each time I run the macro, it copies the rows over, even though they already exist. In my real life application, I would like it to check if the value in Sheet1 (ws44), column B is present in Sheet2 (ws43) column C and only copy the row if the value is NOT present.

I'll work with the code you provided (@LazyBug) but would greatly appreciate your help if you find the solution before I do

Thanks!

 

[cscotty]

Ok, I figured out how to extend the array range and copy the relevant columns over to the appropriate column in worksheet 2:

Sub CompareTwoColumns()

Dim ws44 As Worksheet
Dim ws43 As Worksheet
Set ws44 = Sheets("SAMq")
Set ws43 = Sheets("TEST")
Dim r, d, i&, lr&, f
    With ws44
        r = .Range("A2").CurrentRegion
        Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(r)
                d.Item(r(i, 1)) = Array(r(i, 2), r(i, 3), r(i, 5), r(i, 6), r(i, 7), r(i, 9))
            Next i
    End With
   
    With ws43
        lr = .UsedRange.Row - 1 + .UsedRange.Rows.Count
        For Each r In d.keys
            Set f = .Columns(1).Find(r)
                If f Is Nothing Then
                    .Cells(lr + 1, 2) = r: .Cells(lr + 1, 3) = d.Item(r)(0): .Cells(lr + 1, 4) = d.Item(r)(1)
                    .Cells(lr + 1, 6) = d.Item(r)(2): .Cells(lr + 1, 7) = d.Item(r)(3): .Cells(lr + 1, 8) = d.Item(r)(4)
                    .Cells(lr + 1, 9) = d.Item(r)(5)
                    lr = lr + 1
                End If
        Next r
    End With

End Sub

With my new code, I notice that each time I run the macro, it copies the rows over, even though they already exist. In my real life application, I would like it to check if the value in Sheet1 (ws44), column B is present in Sheet2 (ws43) column C and only copy the row if the value is NOT present.

I'll work with the code you provided (@LazyBug) but would greatly appreciate your help if you find the solution before I do

Thanks!

Ok, I was able to figure it out! Wow this was simple yet complicated . Here is the final code that works great! Please let me know what you think, and if you can still comment it out, that'll be great. Otherwise, I'll continue to read up on Dictionary Keys and Items as I have zero experience with them.

This forum rocks!
Thanks!

 

[LazyBug]

I was able to figure it out!

I have not tested the code you made yourself, but I am very pleased that it works on your specific data. Took the liberty of shortening it a bit, hopefully this will not impair its readability too much. I'll try to comment on the lines of code in as much detail as possible. Hope it will be useful, if not now, then in the future.

Sub CompareTwoColumns()
' Declare variables for this macro. I often give variables short (one- and two-letter) names,
' but it's better to give them longer and clearer names
' Declare r as Variant, d as Variant, i as Long, lr as Long, f as Variant
Dim r, d, i&, lr&, f

    With ActiveWorkbook.Worksheets("SAMq")
        'load the active area of the sheet into the array r (highly recommend to get familiar with the terms UsedRange and CurrentRegion)
        'if you run the code step by step with the F8, you can observe the filling of variables in the Locals window of VBE
        r = .Range("A2").CurrentRegion
        ' create a dictionary and place it to the d variable
        ' In fact, you can do without variable here (With CreateObject("Scripting.Dictionary") block ... End With),
        ' but the available construction allows you to quickly check the state of elements via Immediate window
        Set d = CreateObject("Scripting.Dictionary")
            ' go through the lines of our array (since the first line is the header, we start with the second)
            For i = 2 To UBound(r)
                ' fill in the dictionary, taking as keys the contents of the first column of our array r,
                ' the items become an array of values of the columns we need (here 2, 3, 5, 6 etc.)
                d.Item(r(i, 1)) = Array(r(i, 2), r(i, 3), r(i, 5), r(i, 6), r(i, 7), r(i, 9))
            Next i
    End With
    
    With ActiveWorkbook.Worksheets("TEST")
        ' looking for the last row of Sheet
        lr = .UsedRange.Row - 1 + .UsedRange.Rows.Count
        ' going through the keys of the dictionary
        For Each r In d.keys
            ' look in the first column of the sheet for a match for each of the keys
            Set f = .Columns(1).Find(r)
                ' if not found
                If f Is Nothing Then
                    ' the data from dictionary key are placed in the second column of the current sheet
                    ' on the line following the last
                    .Cells(lr + 1, 2) = r
                    ' in the third column we put the data of the first element of the array,
                    ' which is in the item of the corresponding key
                    .Cells(lr + 1, 3) = d.Item(r)(0)
                    ' to the fourth, the second one
                    .Cells(lr + 1, 4) = d.Item(r)(1)
                    ' In the sixth, the third, etc.
                    .Cells(lr + 1, 6) = d.Item(r)(2)
                    .Cells(lr + 1, 7) = d.Item(r)(3)
                    .Cells(lr + 1, 8) = d.Item(r)(4)
                    .Cells(lr + 1, 9) = d.Item(r)(5)
                    ' increase the counter value of the last row
                    ' so that the new data doesn't overwrite the old ones
                    lr = lr + 1
                End If
        Next r
    End With
End Sub

 

[cscotty]

I have not tested the code you made yourself, but I am very pleased that it works on your specific data. Took the liberty of shortening it a bit, hopefully this will not impair its readability too much. I'll try to comment on the lines of code in as much detail as possible. Hope it will be useful, if not now, then in the future.

Sub CompareTwoColumns()
' Declare variables for this macro. I often give variables short (one- and two-letter) names,
' but it's better to give them longer and clearer names
' Declare r as Variant, d as Variant, i as Long, lr as Long, f as Variant
Dim r, d, i&, lr&, f

    With ActiveWorkbook.Worksheets("SAMq")
        'load the active area of the sheet into the array r (highly recommend to get familiar with the terms UsedRange and CurrentRegion)
        'if you run the code step by step with the F8, you can observe the filling of variables in the Locals window of VBE
        r = .Range("A2").CurrentRegion
        ' create a dictionary and place it to the d variable
        ' In fact, you can do without variable here (With CreateObject("Scripting.Dictionary") block ... End With),
        ' but the available construction allows you to quickly check the state of elements via Immediate window
        Set d = CreateObject("Scripting.Dictionary")
            ' go through the lines of our array (since the first line is the header, we start with the second)
            For i = 2 To UBound(r)
                ' fill in the dictionary, taking as keys the contents of the first column of our array r,
                ' the items become an array of values of the columns we need (here 2, 3, 5, 6 etc.)
                d.Item(r(i, 1)) = Array(r(i, 2), r(i, 3), r(i, 5), r(i, 6), r(i, 7), r(i, 9))
            Next i
    End With
   
    With ActiveWorkbook.Worksheets("TEST")
        ' looking for the last row of Sheet
        lr = .UsedRange.Row - 1 + .UsedRange.Rows.Count
        ' going through the keys of the dictionary
        For Each r In d.keys
            ' look in the first column of the sheet for a match for each of the keys
            Set f = .Columns(1).Find(r)
                ' if not found
                If f Is Nothing Then
                    ' the data from dictionary key are placed in the second column of the current sheet
                    ' on the line following the last
                    .Cells(lr + 1, 2) = r
                    ' in the third column we put the data of the first element of the array,
                    ' which is in the item of the corresponding key
                    .Cells(lr + 1, 3) = d.Item(r)(0)
                    ' to the fourth, the second one
                    .Cells(lr + 1, 4) = d.Item(r)(1)
                    ' In the sixth, the third, etc.
                    .Cells(lr + 1, 6) = d.Item(r)(2)
                    .Cells(lr + 1, 7) = d.Item(r)(3)
                    .Cells(lr + 1, 8) = d.Item(r)(4)
                    .Cells(lr + 1, 9) = d.Item(r)(5)
                    ' increase the counter value of the last row
                    ' so that the new data doesn't overwrite the old ones
                    lr = lr + 1
                End If
        Next r
    End With
End Sub

Thanks LazyBug! The comments really give me a clear picture of code. One more question for you.

Is there a way to bypass the 255 character limit for 'r' (each cell in sheet2)? Whenever a cell containing more than 255 characters is found, I get a "Run-time error '13': Type mismatch". If I remove the excess characters and trim it down to 255 or less, the code works fine.

Please let me know what you think.

Thanks!

 

[LazyBug]

Are you talking about a formula cell with many levels of nesting? Because if we are talking about text content, there can be much more characters (I will attach a fragment of a screenshot). I have not checked, but on the Microsoft website even for excel 2010 it says Total number of characters that a cell can contain - 32,767 characters.