Option Explicit
Sub Pass()
Dim lr As Long, lrD As Long, c As Range, rng As Range
lr = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("B2" & ":B" & lr)
For Each c In rng
lrD = Range("D" & Rows.Count).End(xlUp).Row + 1
If c = "Pass" Then
c.Offset(, -1).Copy Range("D" & lrD)
End If
Next c
End Sub