Comparing 2 Lists and displaying all in New, Removed, Same

[ekryez]

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