Dim Vlooker
Application.ScreenUpdating = False
For Each Vlooker In Sheets("sheet1").Range("a4:a7") 'Where to look first col
If Vlooker.Value = Sheets("sheet1").Range("a1").Value Then ' Search Criteria
Vlooker.Offset(0, 1).Select ' make selection from 2nd Col
Selection.Copy
Sheets("Sheet2").Activate ' copy to Sheet2
If Sheets("Sheet2").Range("a4").Value = "" Then
Sheets("Sheet2").Range("a4").Select
ActiveSheet.Paste
GoTo ender
End If
' Paste second row in cell "A5"
Sheets("Sheet2").Activate
If Sheets("Sheet2").Range("a4").Value > "" And Sheets("Sheet2").Range("a5").Value = "" Then
Sheets("Sheet2").Range("a5").Select
ActiveSheet.Paste
GoTo ender
End If
' Paste subsequent rows in first available cell at bottom
Sheets("Sheet2").Activate
If Sheets("Sheet2").Range("a4").Value > "" And Sheets("Sheet2").Range("a5").Value > "" Then
Sheets("Sheet2").Range("a4").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("sheet1").Activate
End If
ender:
Sheets("sheet1").Activate
End If
Next Vlooker
Dim FindString As String
Dim Rng As Range
Dim fcomp
For Each fcomp In Sheets("sheet2").Range("a2:a9") ' range of Source Comparison
FindString = fcomp
With Sheets("Sheet1").Range("a2:a12") 'range of cells to search
Set Rng = .Find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Rng Is Nothing Then
Else
fcomp.Offset(0, 1).Value = Rng.Offset(0, 4)
End If
End With
Next fcomp