VBA to Compare two different worksheets and copy missing rows

C

cscotty

New Member
Joined
Mar 18, 2021
Messages
15
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!

VBA Code: 
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
 

Attachments

  • vbaHelp.png
    vbaHelp.png
    17.1 KB · Views: 84

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
Hello!
How about
VBA Code: 
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
 
Upvote 0
Solution
LazyBug said:
Hello!
How about
VBA Code: 
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
Click to expand...
Thanks LazyBug! Will give this a try and report back.
 
Upvote 0
LazyBug said:
Hello!
How about
VBA Code: 
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
Click to expand...
LazyBug said:
Of course! Write here if you need more help or if you have any questions.
Click to expand...
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:

VBA Code: 
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!
 
Upvote 0
cscotty said:
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:

VBA Code: 
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!
Click to expand...
Ok, I figured out how to extend the array range and copy the relevant columns over to the appropriate column in worksheet 2:

VBA Code: 
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!
 
Upvote 0
cscotty said:
Ok, I figured out how to extend the array range and copy the relevant columns over to the appropriate column in worksheet 2:

VBA Code: 
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!
Click to expand...
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!
 
Upvote 0
cscotty said:
I was able to figure it out!
Click to expand...
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.
VBA Code: 
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
 
Upvote 0
LazyBug said:
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.
VBA Code: 
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
Click to expand...
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!
 
Upvote 0
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.

len_r.png
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
VBA compare values on different sheets.
Replies
5
Views
99
rlv01
R
S
  • Solved
Copying Filtered Columns (non-adjacent) from one Table to end of another, but need to also add information in adjacent column of Destination Table
Replies
1
Views
376
sspatriots
S
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
278
B-radK
B
C
  • Question
Named ranges from multiple sections of cells copy paste not working
Replies
6
Views
137
Alex Blakenburg
A
S
  • Solved
Run-time error '1004': No cells were found.
Replies
4
Views
614
sspatriots
S

Forum statistics

Threads
1,215,734
Messages
6,126,544
Members
449,316
Latest member
sravya

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top