XL 2019 Utiliser 2 findnext dans la même macro

lovell3

XLDnaute Nouveau
Bonjour ,

J'ai un fichier excel VBA qui par la méthode FindNext m'aide à récupérer 4 variable dans plusieurs fichiers.

Je souhaite par la suite mettre un autre findNext dans la même macro pour me récupérer Une variable présente autant de fois qu'il ya de variable dans la première recherche.

seulement la macro ne tourne que sur une ligne dont me récupère l'information une seule fois.

Ci-dessous mon code

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
 

Dudu2

XLDnaute Barbatruc
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.
 

lovell3

XLDnaute Nouveau
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.
Bonjour Dudu2

deja merci pour le temps que tu as accordé à ma question et la réponse.
Je ne suis pas sûr d’avoir compris le principe pour la première et deuxième recherche si comment rendre mon code lisible.
si tu peux stp me mettre les commentaires sur le côté .
Merci ☺️
 

Dudu2

XLDnaute Barbatruc
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...
 

Pièces jointes

  • VBA Recherche avec marquage Shape flèche.xlsm
    24.5 KB · Affichages: 8

lovell3

XLDnaute Nouveau
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...
Bonjour Dudu2 ,

je pense que mon besoin n’a pas été Compris.
je fais deux recherches et sur l’une une des recherches j’ai plusieurs résultats à récupérer par la méthode find
Sauf que la deuxième fonction FInd ne récupère qu’une seule fois la valeur au lieu de récupérer les valeurs suivantes comme la première recherche.

merci pour ta réponse, en espérant d’avoir la solution.
 

Dudu2

XLDnaute Barbatruc
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.
 
Dernière édition:

lovell3

XLDnaute Nouveau
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.
Bonjour Dudu2
Merci d’avoir mis mon code lisible.
Les informations ont été modifié parce que l’extrac que j’ai fais contenait des informations confidentielles donc des erreurs ont pu se glisser.
je n’ai pas de problème avec la macro elle fonctionne normalement. Le seul bémol c’est qu’elle s’arrête sur la première valeur trouvé et pas ne continue pas la recherche et donc l’extraction des valeurs suivantes.
Bien merci
 

Dudu2

XLDnaute Barbatruc
Sans fichier ni exemple de problème, c'est absolument impossible à trouver.
On ne sait pas ce qu'il y a dans les feuilles, on ne sait pas quel est le code réel puisque tu en as fait un extrait.
Je ne peux que te renvoyer à mes premières réponses sur les instructions à utiliser.
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof