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
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
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
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
