```
Sub Compare_Sync()
Dim n&, nDiff&
Dim key, keyRef
Dim cell As Range
Dim rngList1 As Range, rngList2 As Range
Dim rngListRef As Range, rngList As Range
Dim dNameRef As Object, dName As Object
Set dNameRef = CreateObject("Scripting.Dictionary")
Set dName = CreateObject("Scripting.Dictionary")
Set rngList1 = Range("A2", "A6")
Set rngList2 = Range("D2", "D9")
Application.ScreenUpdating = False
' Fill dictionaries
If rngList1.Count > rngList2.Count Then
Set rngListRef = rngList1
Set rngList = rngList2
Else
Set rngListRef = rngList2
Set rngList = rngList1
End If
For Each cell In rngListRef
dNameRef.Add cell.Value, cell.Row & " " & cell.Offset(0, 1)
Next
For Each cell In rngList
dName.Add cell.Value, cell.Row & " " & cell.Offset(0, 1)
Next
' Write result
Range("A1", "B1").Copy Range("H1")
Range("D1", "E1").Copy Range("K1")
n = 1
For Each key In dName
If dNameRef.Exists(key) Then
Result = Split(dName(key))
ResultRef = Split(dNameRef(key))
Select Case True
Case Result(0) = ResultRef(0)
n = n + 1
Range("H" & n) = key
Range("I" & n) = Result(1)
Range("K" & n) = key
Range("L" & n) = ResultRef(1)
dName.Remove key
dNameRef.Remove key
Case Else
nDiff = 0
nDiff = ResultRef(0) - Result(0)
For Each keyRef In dNameRef
If keyRef = key Then
n = n + 1
ResultRef = Split(dNameRef(keyRef))
Range("H" & n) = key
Range("I" & n) = Result(1)
Range("K" & n) = key
Range("L" & n) = ResultRef(1)
dName.Remove key
dNameRef.Remove key
Exit For
Else
n = n + 1
Result = Split(dName(key))
ResultRef = Split(dNameRef(keyRef))
Range("H" & n) = keyRef
Range("I" & n) = 0
Range("K" & n) = keyRef
Range("L" & n) = ResultRef(1)
dNameRef.Remove keyRef
End If
Next
End Select
Else
n = n + 1
Result = Split(dName(key))
Range("H" & n) = key
Range("I" & n) = Result(1)
Range("K" & n) = key
Range("L" & n) = 0
dName.Remove key
End If
Next
End Sub
```