Option Explicit
'========================
'= Procédure principale =
'========================
Sub Main()
'# Déclaration des variables de la procédure
Dim oFso As Object
Dim oFile As Object
Dim oDirectory As Object
Dim wkbDEST As Workbook
Dim wkbSOURCE As Workbook
Dim wks As Worksheet
Dim i As Long 'Compteur pour décalage des lignes
'# Création des objets de scripting
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oDirectory = oFso.getfolder(Range("sPath"))
'# Affectation de la variable wkbDEST au classeur accueillant les données
Set wkbDEST = ThisWorkbook
'# On active la gestion d'erreur
On Error GoTo GestionErreur
'# On vérifie qu'il y a bien des fichiers dans le répertoire
If Not (oDirectory.Files.Count > 0) Then
MsgBox "Le répertoire sélectionné ne contient aucun fichier !", vbCritical + vbOKOnly, "Erreur répertoire"
Exit Sub
End If
'# Effacement de la plage de données
wksDatabase.Range("A1").CurrentRegion.Clear
'# Désactivation de certains paramètres pour accélerer le traitement
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
'# On parcours tous les fichiers du répertoire
For Each oFile In oDirectory.Files
'# Si le fichier est un fichier Excel on l'ouvre. Attention il n'y a aucune
'# vérification
If Right(oFile.Name, 4) = ".xls" Then
Workbooks.Open Range("sPath") & "\" & oFile.Name
Set wkbSOURCE = ActiveWorkbook
'# On parcours les onglets du fichier.
'# S'il s'agit d'un nombre c'est un site et on copie.
For Each wks In wkbSOURCE.Worksheets
'# Si le nom fait 3 caractère alors il s'agit d'une source
If Len(wks.Name) = 3 Then
i = i + 1
With wksDatabase
.Cells(i, 1) = wks.Name
.Cells(i, 2) = wks.Range("D13")
.Cells(i, 3) = wks.Range("E13")
.Cells(i, 4) = wks.Range("D22")
.Cells(i, 5) = wks.Range("E22")
.Cells(i, 6) = wks.Range("G24")
End With
End If
Next
End If
Next
GestionErreur:
'# On ferme les objets créés
Set oFso = Nothing
Set oDirectory = Nothing
'# Rétablissement des paramètres Excel
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "Les données des fichiers ont été importées avec succès.", vbOKOnly + vbInformation, "Fin Traitement"
End Sub