FindNextがうまくいかない

VBAで以下を作成しました。
①研修受講者
②研修詳細情報
③白紙フォーマット
④受講者詳細情報
のシートがあり、研修ごとに受講者一覧を作成するVBAを作成したいです。
研修名称を②の分類シートからFindで探し、必要なデータを転記し、
FindNextで同じ研修名の別日程も作成できるようにしたいです。
Findはうまくいくのですが、FindNextではNothingになってしまいます。
なにがいけないのでしょうか。
また、なにか他のやり方はありますでしょうか。
VBA初心者で調べながら作成していますので、めちゃくちゃかもしれません。
ご教示お願いいたします。
宣言のみ省かせていただきます。
----
flag = 0

Set ws1 = Worksheets("データ")
Set ws2 = Worksheets("分類")
Set ws3 = Worksheets("フォーマット３")
Set ws4 = Worksheets("名簿")

Application.ScreenUpdating = False

lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lRow
n = Application.WorksheetFunction.CountIf(Range(ws1.Cells(2, 6), ws1.Cells(i, 6)), ws1.Cells(i, 6))

If n = 1 Then
ws3.Range("A11").Value = ws1.Cells(i, 6)

Set search = ws2.Range("C:C")

x = ws3.Range("A11").Value
Set findtitle = search.Find(x, LookIn:=xlValues, LookAt:=xlWhole)
Set tmpfindt = findtitle


Do

ws3.Range("C4").Value = ws2.Cells(findtitle.Row, findtitle.Column + 4).Value '実施部門
dating = CDate(ws2.Cells(findtitle.Row, findtitle.Column + 2).Value)
ws3.Range("C5").Value = Format(dating, "mm月dd日") '実施日時
ws3.Range("C6").Value = ws2.Cells(findtitle.Row, findtitle.Column + 5).Value '実施場所
ws3.Range("C7").Value = ws2.Cells(findtitle.Row, findtitle.Column + 6).Value '対象
ws3.Range("A9").Value = ws2.Cells(findtitle.Row, findtitle.Column + 7).Value 'テキスト
ws3.Range("E9").Value = ws2.Cells(findtitle.Row, findtitle.Column + 1).Value '講師



k = 13

For j = 2 To lRow
If ws1.Cells(j, 6).Value = ws3.Range("A11").Value And dating = ws1.Cells(j, 4).Value Then


mail = ws1.Cells(j, 1).Value
Set findno = ws4.Columns("B").Find(mail, LookAt:=xlWhole)

ws3.Cells(k, 2).Value = ws4.Cells(findno.Row, findno.Column + 1).Value '所属
ws3.Cells(k, 3).Value = ws4.Cells(findno.Row, findno.Column - 1).Value '職番
ws3.Cells(k, 4).Value = ws4.Cells(findno.Row, findno.Column + 2).Value '名前
k = k + 1
End If




Next j

ws3.Copy After:=Worksheets(Worksheets.Count) '「フォーマット３」シートをコピー

Set ws5 = ActiveSheet 'コピーしたシートを変数にセット
wsname = ws2.Cells(findtitle.Row, findtitle.Column - 2).Value & "=" & Range("A11").Text
ws5.name = wsname & "_" & Format(dating, "mm月dd日")

Application.DisplayAlerts = False

ReDim Preserve copy_sheet(flag)

copy_sheet(flag) = ws5.name

flag = flag + 1


Set findtitle = search.FindNext(After:=findtitle)

If findtitle Is Nothing Then
Exit Do
End If


If findtitle.Address = tmpfindt.Address Then
Exit Do
End If

（データ削除）


Loop

ThisWorkbook.Worksheets(copy_sheet).Copy

ActiveWorkbook.SaveAs _
filename:=ThisWorkbook.Path & "\" & wsname & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook 'MacroEnabled


ActiveWorkbook.Close

ThisWorkbook.Worksheets(copy_sheet).Delete
Application.DisplayAlerts = True

End If

Next i

No.1 回答者： めぐみん_ 回答日時： 2021/05/12 20:51

Findメソッドを２重にかけているので条件がすり替わっているのでは？

Set findtitle = search.FindNext(After:=findtitle)

↓

Set findtitle = search.Find(x,After:=findtitle, LookIn:=xlValues, LookAt:=xlWhole)

でいけるかな？（未検証）