re,
Sub GetFilesInFolder()
Dim WS As Worksheet
Dim FSO As Scripting.FileSystemObject
Dim SourceFolderName As String, DestinationFolderName As String
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.file
Dim FileNamesArray() As String
Dim i As Long, iLig As Long, NbLig As Long, FileNameValue As Long
Set WS = Worksheets("Sheet1")
SourceFolderName = "C:\Users\Desktop\Test\"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
ReDim FileNamesArray(1 To SourceFolder.Files.Count)
NbLig = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
dern = Sheets(1).Range("A1").End(xlDown).Row
Dim tableau()
ReDim tableau(dern + 1, 2)
For x = 2 To dern
tableau(x - 2, 0) = Sheets(1).Cells(x, 1)
tableau(x - 2, 1) = Sheets(1).Cells(x, 2)
Next
For iLig = 0 To dern
i = 0
For Each FileItem In SourceFolder.Files
i = i + 1
FileNamesArray(i) = FileItem.Name
FileNameValue = Application.Trim(VBA.Split(FileNamesArray(i))(2))
If tableau(iLig, 0) = FileNameValue Then
tableau(iLig, 2) = "TRUE" '.Cells(iLig, 2).Interior.Color = xlNone
'.Cells(iLig, 3).Value = "TRUE"
Exit For
Else
'.Cells(iLig, 2).Interior.Color = RGB(255, 64, 0)
tableau(iLig, 2) = "FALSE"
End If
Next FileItem
Next iLig
Application.ScreenUpdating = True
For y = 2 To dern
Sheets(1).Cells(y, 3) = tableau(y - 2, 2)
Next
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
essaies de cette facon
il y a peut etre des erreurs , j ai pas tres bien verifié mais potentiellement ca peut aller plus vite dans l idée