I changed according to the suggestions. Tried again but the iterations now runs without stop. What is wrong with the loop?

Option Explicit
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

Set FindSht = Sheets("Find")
FindSht.Range(Cells(2, 2), Cells(6666, 20)).ClearContents
lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
  SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = FindSht.UsedRange.Rows.Count

For i = 2 To lastrw
    vFind = FindSht.Cells(i, 1)
    For Each ws In Worksheets
        lastrow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
        If ws.Name <> FindSht.Name Then
            ws.Select
            Set rFound = Cells.Find(what:=vFind, After:=[A1], LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
                If Not rFound Is Nothing Then
                    rFoundCol = rFound.Column
                    If 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 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
                End If
        End If
    Next ws
Next i

Application.ScreenUpdating = True
Set FindSht = Nothing
Set rFound = Nothing
End Sub