Maybe this
Option Explicit
Sub x()
Dim rng As Range
Dim rngCheck As Range
Dim cl As Range
Dim cl2 As Range
Dim sFind As String
Dim sAdd As String
Set rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
Set rngCheck = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))
For Each cl In rng
If Not IsEmpty(cl.Offset(0, 1)) Then
sFind = cl.Value
With rngCheck
Set cl2 = .Find(sFind, LookIn:=xlValues)
If Not cl2 Is Nothing Then
sAdd = cl2.Address
Do
cl.Value = cl2.Offset(0, 1).Value
Set cl2 = .FindNext(cl2)
Loop While Not cl2 Is Nothing And cl2.Address <> sAdd
End If
End With
End If
Next cl
End Sub
Bookmarks