another option
Option Explicit
Sub ptest()
Dim found As Range, LookFor$, fAddress$, i!, ii!
[F3:V27].ClearContents
[A1].Activate
With Worksheets(1).Range("B1", Range("B" & Rows.Count).End(xlUp))
For ii = 0 To 16 Step 2
LookFor = [F2].Offset(0, ii)
Set found = .Find(LookFor, LookIn:=xlValues)
i = 1
If Not found Is Nothing Then
fAddress = found.Address
Do
[F2].Offset(i, ii + 0) = found.Offset(0, -1)
i = i + 1
Set found = .FindNext(found)
Loop While Not found Is Nothing And found.Address <> fAddress
End If
Next ii
End With
End Sub
but using excel functions where possible is allways the first choice
Bookmarks