VBA : Retour à la ligne avec conditionnalité

Sub toto()
Dim Cel As Range
Dim C As Range, D As Range
Application.ScreenUpdating = False
With Columns(2)
    Set C = .Find("TOTO")
    If Not C Is Nothing Then
        PremAdress = C.Address
        Do
            Set D = .FindNext(C)
            If Not D Is Nothing And D.Row > C.Row Then
                C.Resize(D.Row - C.Row, 1).Copy
                Sheets("Résultat souhaité").Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
            Else
                C.Resize([B65000].End(xlUp).Row + 1 - C.Row, 1).Copy
                Sheets("Résultat souhaité").Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                Application.CutCopyMode = False
                Exit Sub
            End If
            Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address <> FirstAddress
    End If
End With
End Sub


Sub toto2()
Dim Cel As Range
Dim LeMot As Object
Dim DerLig As Long, I As Long
Dim F1 As Worksheet, F2 As Worksheet
Dim Temp
Application.ScreenUpdating = False
Set F1 = Sheets("DATA")
Set F2 = Sheets("Résultat souhaité")
Set LeMot = CreateObject("Scripting.Dictionary")
DerLig = F1.[B65000].End(xlUp).Row
For Each Cel In F1.Range("B2:B" & DerLig)
    If Cel.Value = "TOTO" Then LeMot(Cel.Row) = Cel.Row
Next Cel
Temp = LeMot.Items
For I = LBound(Temp) To UBound(Temp)
    If I < UBound(Temp) Then
        F1.Range(F1.Cells(Temp(I), 2), F1.Cells(Temp(I + 1) - 1, 2)).Copy
        F2.Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Else
        F1.Range(F1.Cells(Temp(I), 2), F1.Cells(DerLig, 2)).Copy
        F2.Range("D65000").End(xlUp)(2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    End If
Next I
Application.CutCopyMode = False
End Sub

Set C = .Find("TOTO", LookAt:=xlPart)

If Cel.Value Like "*TOTO*" Then LeMot(Cel.Row) = Cel.Row

Sub test()
    Dim Str_Plage As String
    Dim Cel As Range
    Dim Feuil As Worksheet
    Dim Str_critère As String
    Str_Plage = "B1:B112"
    Str_critère = "toto"
    If Str_critère = "" Then GoTo fin
    Columns("E:E").Select
    Selection.ClearContents
    For Each Feuil In Sheets
        For Each Cel In Feuil.Range(Str_Plage)
            If UCase(Cel) Like "*" & UCase(Str_critère) & "*" Then
                Feuil.Activate
                Cel.Activate
                Z = Cel.Row
                Cells(Range("e65536").End(xlUp).Row + 1, 5).Value = Z
            End If
        Next Cel
    Next Feuil
    Cells(Range("e65536").End(xlUp).Row + 1, 5).Value = Range("b65536").End(xlUp).Row + 1
    On Error GoTo fin
    For y = 2 To Range("e65536").End(xlUp).Row
        Range("B" & Cells(y, 5) & ":B" & Cells(y + 1, 5) - 1).Select
        Selection.Copy
        Cells(Range("f65536").End(xlUp).Row + 1, 6).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                               False, Transpose:=True
    Next
fin:
    Columns("E:E").Select
    Selection.ClearContents
End Sub