XL 2019 Utiliser 2 find dans macro

Sub research_data()

Dim xFso As Object
Dim xFld As Object
Dim xStrSearch(1 To 4) As String
Dim xStrSearch5 As String
Dim xStrSearch6 As String
Dim xStrSearch7 As String
Dim xStrSearch8 As String
Dim xStrSearch9 As String
Dim xStrSearch10 As String
Dim xStrSearch11 As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xFound2 As Range
Dim xFound3 As Range
Dim xFound4 As Range
Dim xFound5 As Range
Dim xFound6 As Range
Dim xFound7 As Range
Dim xFound8 As Range
Dim xFound9 As Range
Dim xFound10 As Range
Dim xFound11 As Range
Dim plage As Range
Dim xStrAddress As String
Dim xStrAddress5 As String
Dim xStrAddress6 As String
Dim xStrAddress7 As String
Dim xStrAddress8 As String
Dim xStrAddress9 As String
Dim xStrAddress10 As String
Dim xStrAddress11 As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
Dim i As Long
Dim y As Long
Dim LastRow As Long
Dim jxRow As Long



On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub

xStrSearch(1) = "DEVIS"
xStrSearch(2) = "FACTURE"
xStrSearch(3) = "FRAIS DE LIVRAISON"
xStrSearch(4) = "RECPETION"

xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets("Feuil1")
xRow = 1
With xOut
Cells(xRow, 1) = "Titulaire"
.Cells(xRow, 2) = "Numéro de client"
.Cells(xRow, 3) = "Type de client"
.Cells(xRow, 4) = "Date de mise en service"


Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
LastRow = xRow + 1
For i = LBound(xStrSearch) To UBound(xStrSearch)
Set xFound = xWk.Range("A16:D27").Find(xStrSearch(i))
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else


xCount = xCount + 1
xRow = xRow + 1


.Cells(xRow, 1) = Replace(xWb.Name, ".xlsx", "")
.Cells(xRow, 2) = xWk.Range("A2")
.Cells(xRow, 3) = Replace(xFound.Value, "n", "")


End If
Set xFound = xWk.Range("A16:D27").FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address

Set xFound5 = xWk.Range("A1:F60000").Find(xStrSearch5)
xStrAddress5 = xFound5.Address
xStrSearch5 = "DATE DE MISE EN SERVICE"
Set xFound5 = xWk.Range("A1:F60000").Find(xStrSearch5)
For jxRow = xRow To LastRow
xStrAddress5 = xFound5.Address
.Cells(xRow, 4) = xFound5.Offset(0, 1).Value
Set xFound5 = xWk.Range("A1:F60000").FindNext(After:=xFound5)
On Error Resume Next
Next




Next

Next


xWb.Close (False)
xStrFile = Dir


Loop
.Columns("A:E").EntireColumn.AutoFit
End With
MsgBox xCount & "cells have been found", , "Kutools for Excel"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub