I added comments to my suggestions, but there's only one item that populates. Spot checking, that seems like all that should
Sub test()
Dim lastcol As Integer, lastrw As Long, lastrow As Long, i As Long
Dim ws As Worksheet, FindSht As Worksheet, vFind, rFound As Range, rFoundCol As Integer
Dim rCell As Range
Set FindSht = Sheets("Find")
'any reason why 6666?
FindSht.Cells(2, 2).Resize(6666, 20).ClearContents
lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
SearchDirection:=xlPrevious).EntireColumn.Column
' lastrw = FindSht.UsedRange.Rows.Count
' lastrw = 6666
' lastrw = 5 this way
lastrw = FindSht.Cells(1, 1).CurrentRegion.Rows.Count
'you've got trailing spaces in your data
For Each ws In Worksheets
For Each rCell In ws.Cells(1, 1).CurrentRegion.Cells
rCell.Value = Trim(rCell.Value)
Next
Next
For i = 2 To lastrw
vFind = FindSht.Cells(i, 1)
For Each ws In Worksheets
If ws.Name = FindSht.Name Then GoTo GetNextSheet
'need to use specific sheet (ws.) for Cells and Rows
lastrow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
'wouldn't you want to look in Values instead of the Formulas which are not there?
Set rFound = ws.Cells.Find(what:=vFind, After:=[A1], LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rFound Is Nothing Then GoTo GetNextRow
rFoundCol = rFound.Column
'FROM and TO are in the First not fifth row
If ws.Cells(1, rFoundCol).Value = "FROM" Then
FindSht.Cells(i, rFoundCol).Value = rFound
FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
ElseIf ws.Cells(1, rFoundCol).Value = "TO" Then
FindSht.Cells(i, rFoundCol).Value = rFound
FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
End If
GetNextSheet:
Next ws
GetNextRow:
Next i
Application.ScreenUpdating = True
Sheets("Find").Select
End Sub
Paul