Sub SearchFiles()
Dim nbLignes As Long
Dim Chemin
nbLignes = Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row
'Efface les données existantes avant de copier
'Effacer cette ligne si ce n'est pas nécessaire
Sheets("Feuil1").Range("A2:F" & nbLignes).EntireRow.Delete
Chemin = BrowseForFolder("C:\Users\seb\Desktop") 'Changer le C pour autre chose si nécessaire
ImportFiles Chemin 'Changer au besoin
Sheets("Feuil1").Sort.SortFields.Add Key:=Range("A2:A" & nbLignes), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Feuil1").Sort
.SetRange Range("A1:E" & nbLignes)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
MsgBox "Terminé"
End Sub
Sub ImportFiles(varPath As Variant)
Dim nbLignes As Long
Dim varFile As Variant
Dim objColl As Collection
On Error GoTo Erreur
Set objColl = New Collection
If Right(varPath, 1) <> "\" Then varPath = varPath & "\"
varFile = Dir(varPath, vbDirectory + vbArchive)
Do While varFile <> ""
'Stocke le répertoire
If GetAttr(varPath & varFile) = vbDirectory Then
If Left(varFile, 1) <> "." Then
objColl.Add varPath & varFile
End If
'Travailler avec le fichier
ElseIf LCase(Right(varFile, 3)) = "xls" Or LCase(Right(varFile, 4)) = "xlsx" Then
'Détermine la première ligne vide du classeur Résultats
nbLignes = ThisWorkbook.Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row + 1
'Ouvrir le fichier, copier les données et le fermer
Workbooks.Open varPath & varFile, , True
ActiveWorkbook.Sheets("Tab").Range("D13").Copy
ThisWorkbook.Sheets("Feuil1").Range("A" & nbLignes).PasteSpecial xlPasteValues
ActiveWorkbook.Close False
End If
varFile = Dir
Loop
For Each varFile In objColl
ImportFiles varFile
Next
Set objColl = Nothing
Exit Sub
Erreur:
MsgBox Err.Number & vbCrLf & Err.Description
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, CVar(OpenAt))
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Erreur
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Erreur
Case Else
GoTo Erreur
End Select
Set ShellApp = Nothing
Exit Function
Erreur:
BrowseForFolder = False
End Function