Adding Data & Comparing Lists

Sub ADDCLM()
On Error Resume Next
    
    Dim Amt_Row As Long
    Dim Amt_Clm As Long
    
    Dim tblwidth As Long
    Dim tblheight As Long
    
    Set sh1 = Sheets("SHEET 1") 'Edit sheet name
    Set sh2 = Sheets("SHEET 2") 'Edit sheet name

    'Go to first non-empty cell in Column A (where the Table should be)
    With Columns("A")
    .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlValues).Activate
    End With
    
    'Select the Table region and define table width and height
    Set tbl = ActiveCell.CurrentRegion
    'tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
    tblwidth = tbl.Columns.Count
    tblheight = tbl.Rows.Count - 1
    
    'Specifying Range of First Column for Table 1 - the Table to copy data to
    Table1 = sh1.Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row + tblheight, 1))
    
    'Specifying Range for Table 2 - the Table to copy data from
    Table2 = sh2.Range("a1:b" & sh2.Cells(Rows.Count, "B").End(xlUp).Row)
   
    
    'On Error GoTo Err_Execute
    'Append relevant data from correct rows as an extra column to Table1
     
            Amt_Clm = ActiveCell.Column + tblwidth
            Amt_Row = ActiveCell.Row
            For Each cl In Table1
            sh1.Cells(Amt_Row, Amt_Clm) = Application.WorksheetFunction.VLookup(cl, Table2, 2, False)
            Amt_Row = Amt_Row + 1
            Next cl
            
    MsgBox "Done"

End Sub

Sub CompareLists()

Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr1 As Long, lr2 As Long, rng1 As Range, rng2 As Range, c As Range
Set sh1 = Sheets("SHEET 1") 'Edit sheet name
Set sh2 = Sheets("SHEET 2") 'Edit sheet name
Set sh3 = Sheets("SHEET 3") 'Edit sheet name

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

Set rng1 = sh1.Range("A2:A" & lr1) 'Establish the ranges on both sheets
Set rng2 = sh2.Range("A2:A" & lr2)

With sh3 'If header not there, put them in
    If .Range("B1") = "" And .Range("C1") = "" Then
        .Range("B1") = "Extras in List 1"
        .Range("C1") = "Extras in List 2"
    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, 2).End(xlUp)(2) = c.Value
        End If
    Next
    For Each c In rng2
        If Application.CountIf(rng1, c.Value) = 0 Then
            sh3.Cells(Rows.Count, 3).End(xlUp)(2) = c.Value
        End If
    Next
    
MsgBox "Done"

End Sub