Sub PTR()
nbp = 1: boucle = 1: seuil = Int(65536 / 100)
MyTextB = UserForm1.TextBox1.Value
Sheets("Feuil2").Range("A2:h65536").ClearContents
If Trim(MyTextB) <> "*" Then
With Worksheets("Patrimoine")
Set rB = .Range("A4:A65536")
End With
Set rFoundB = rB.Resize(1, 1)
Set B = rB.Find(MyTextB, After:=rFoundB, _
LookIn:=xlValues, _
Lookat:=xlPart)
If Not B Is Nothing Then
firstAddress = B.Address
S = ""
Do
nbp = nbp + 1
'Stop
If nbp > seuil Then Application.StatusBar = boucle & " %": boucle = boucle + 1: nbp = 1
bcopy = False
If (InStr(1, B.Offset(0, 1), Trim(MyTextC), vbTextCompare) > 0 _
Or Trim(MyTextC) = "*" _
Or Len(Trim(MyTextC)) = 0) And _
(InStr(1, B.Offset(0, 2), Trim(MyTextD), vbTextCompare) > 0 _
Or Trim(MyTextD) = "*" Or Len(Trim(MyTextD)) = 0) Then
lr = Sheets("Feuil2").Cells(Rows.Count, "a").End(xlUp).Row + 1
B.EntireRow.Copy Sheets("Feuil2").Rows(lr)
FoundCount = FoundCount + 1
S = S & Sheets("Feuil2").Cells(lr, "A").Text
S = S & " - " & Sheets("Feuil2").Cells(lr, "B").Text
S = S & " " & Sheets("Feuil2").Cells(lr, "C").Text & " " & vbNewLine
End If
Set B = rB.FindNext(B)
Loop While Not B Is Nothing And B.Address <> firstAddress
If Len(Trim(S)) > 0 Then
txtresult = S
MsgBox FoundCount & " Valeurs trouvés", vbInformation, "Recherche complété"
Sheets("Feuil2").Select
End If
End If
End If
Unload BaredeProgression
End Sub