XL 2019 Utiliser 2 findnext dans la même macro

Dudu2 à dit:

Bonjour,
Si tu pouvais mettre ton code dans un format correct (utiliser </>) ce serait déjà un gros progrès pour la lisibilité.
D'une manière générale, un recherche initiale se présente sous cette forme:

VB:

On Error Resume Next
Set Cellule = Cells.Find(What:=SearchString, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
ErrorNumber = Err.Number
On Error GoTo 0
If ErrorNumber = 0 Then ...

Et une recherche suivante:

Code:

Set Cellule = Cells.FindNext(After:=Cellule)

La recherche bouclant sur elle-même.

Cliquez pour agrandir...

Dudu2 à dit:

Je ne sais pas trop ce que je peux faire de plus pour t'aider. J'ai donné les instructions à utiliser.
Sinon voici un exemple...

Cliquez pour agrandir...

Dudu2 à dit:

Déjà voilà ton code indenté et donc devenu lisible pour les personnes qui souhaitent faire des investigations.
C'était plutôt à toi de le faire me semble-t-il.

VB:

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 jxRow
                Next i
            Next xWk
            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

Si tu cherches RECEPTION je pense qu'il y a un problème avec xStrSearch(4) = "RECPETION".
Il y a un On Error Resume Next qui vient en conflit avec le On Error du début.
Dans l'instruction Cells(xRow, 1) = "Titulaire" , la cellule n'est pas qualifiée.
xFileDialog.Title = "Select a forlder" Pour info en anglais on dit un folder
L'initialisation xRow = 1 est placée trop haut me semble-t-il.
Manifestement tu ne vérifies pas ton code. Un conseil... relis ton code et fait comme Einstein, une expérience de pensée en l'exécutant mentalement tout en le relisant.

Cliquez pour agrandir...