Comparing 2 Lists and displaying all in New, Removed, Same Excel- VBA

[Edwardryez]

Sub divide()
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("a")
Set sh2 = Sheets("b") 
Set sh3 = Sheets("Result") 
lr1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row 
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
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") = "" And .Range("B1") = "" Then
        .Range("A1") = "New"
        .Range("B1") = "Removed"
    End If
......."Same"
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
            sh3.Cells(Rows.Count, 2).End(xlUp)(2) = c.Value
        End If
    Next
End Sub

Can someone help modifying this code. All in same Worksheet, instead of 3
First - The Range to be input ie
InputBox ("Enter the Range: ")
and
adding a third loop displaying the same items in both lists