Macro to find differents in A column but past all the row for the difference

[starheartbeam]

I haves at 2 columns on different tabs and find the ones that are different betweenthe two and put them on different tabs. The code works to find thedifferent but I also need to take the columns rest of its row and also copy onthe new tab. Right now it is just pasting the column A but I need it to paste all of the row where A is added or removed.

Private Sub CommandButton1_Click()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, lr1 As Long, lr2 As Long, rng1 As Range, rng2 As Range, c As Range
Set sh1 = Worksheets("Jan_3_19")
Set sh2 = Worksheets("Jan_10_19")
Set sh3 = Worksheets("Removed")
Set sh4 = Worksheets("Added")
lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'Get the last row with data for both list sheets
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
            'Establish the ranges on both sheets
Set rng2 = sh2.Range("A2:A" & lr2)
With sh3 'If header not there, put them in
    If .Range("A1") = "" Then
        .Range("A1") = "Removed"
        .Range("B1") = "Location"
        .Range("C1") = "Start"
        .Range("D1") = "End"
    End If
End With
With sh4 'If header not there, put them in
    If .Range("A1") = "" Then
        .Range("A1") = "Added"
        .Range("B1") = "Location"
        .Range("C1") = "Start"
        .Range("D1") = "End"
       End If
End With
    For Each c In rng1 'Run a loop for each list ID mismatches and paste to sheet 3.
        If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
            sh3.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
        End If
    Next
    For Each c In rng2
        If Application.CountIf(rng1, c.Value) = 0 Then
            sh4.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
        End If
    Next[/FONT][/COLOR]

[COLOR=#222222][FONT="Verdana"]End Sub

 

[DanteAmor]

Faltaba este set

Set rng1 = sh1.Range("A2:A" & lr1)

Try this:

Private Sub CommandButton1_Click()
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
    Dim lr1 As Long, lr2 As Long, rng1 As Range, rng2 As Range, c As Range
    Set sh1 = Worksheets("Jan_3_19")
    Set sh2 = Worksheets("Jan_10_19")
    Set sh3 = Worksheets("Removed")
    Set sh4 = Worksheets("Added")
    lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'Get the last row with data for both list sheets
    lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
                'Establish the ranges on both sheets
    Set rng1 = sh1.Range("A2:A" & lr1)
    Set rng2 = sh2.Range("A2:A" & lr2)
    With sh3 'If header not there, put them in
        If .Range("A1") = "" Then
            .Range("A1") = "Removed"
            .Range("B1") = "Location"
            .Range("C1") = "Start"
            .Range("D1") = "End"
        End If
    End With
    With sh4 'If header not there, put them in
        If .Range("A1") = "" Then
            .Range("A1") = "Added"
            .Range("B1") = "Location"
            .Range("C1") = "Start"
            .Range("D1") = "End"
           End If
    End With
    For Each c In rng1 'Run a loop for each list ID mismatches and paste to sheet 3.
        If WorksheetFunction.CountIf(rng2, c.Value) = 0 Then
            'sh3.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
            sh1.Rows(c.Row).Copy sh3.Cells(sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
        End If
    Next
    For Each c In rng2
        If Application.CountIf(rng1, c.Value) = 0 Then
            'sh4.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
            sh2.Rows(c.Row).Copy sh4.Cells(sh4.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
        End If
    Next
End Sub

 

[starheartbeam]

This worked! Thank you so much for your help!

 

[DanteAmor]

I'm glad to help you