chen301222

Sub FIND()
Dim arr, i, j, d As Object
Set d = CreateObject("Scripting.Dictionary")
With Sheets("sheet2")
    arr = .[a1].CurrentRegion
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                d(arr(i, j)) = arr(1, j)
            End If
        Next j
    Next i
End With
With Sheets("sheet1")
    arr = .[a1].CurrentRegion
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1)) Then
            arr(i, 4) = d(arr(i, 1))
        End If
    Next i
    .[a1].CurrentRegion = arr
End With
End Sub