Public Sub Consolider_classeurs_dossier()
'Empile dans une seule feuille le contenu de tous les classeurs d'un dossier.
'Attend : le chemin du dossier, à écrire sur la ligne « dossier = » ci-dessous,
' et des classeurs dont la première feuille porte ses en-têtes sur sa
' première ligne remplie.
'Modifie : crée dans le classeur actif une feuille « Consolidation » et y écrit
' les lignes de chaque classeur, précédées du nom du fichier, dans
' l'ordre alphabétique des noms. Une feuille « Consolidation » déjà
' présente est VIDÉE avant l'écriture, et Ctrl+Z ne la ramène pas.
' Les classeurs sources ouverts par la macro sont refermés sans être
' modifiés. Un classeur qui était DÉJÀ ouvert avant le lancement est lu
' tel quel et laissé ouvert : le refermer jetterait un travail non
' enregistré.
' Un fichier vide, protégé par un mot de passe, illisible, ou du même
' nom qu'un classeur ouvert depuis un autre dossier est sauté, et le
' compte rendu le nomme. Chaque colonne rejoint celle qui porte le même
' en-tête, dans n'importe quel ordre ; un en-tête inconnu ajoute une
' colonne à droite, et le compte rendu nomme le fichier qui l'apporte.
'Windows : sur Excel Mac, le bac à sable rend invisible un dossier qui n'a pas
' été autorisé. La macro annonce alors qu'il ne contient aucun
' classeur, ce qui est faux.
Dim destination As Workbook
Dim classeur As Workbook
Dim aFermer As Workbook
Dim ouvert As Workbook
Dim cible As Worksheet
Dim feuille As Worksheet
Dim plage As Range
Dim zone As Range
Dim noms() As String
Dim entetes() As String
Dim colonneCible() As Long
Dim prise() As Boolean
Dim tableau() As Variant
Dim sortie() As Variant
Dim valeurs As Variant
Dim ecrites As Variant
Dim dossier As String
Dim separateur As String
Dim fichier As String
Dim chemin As String
Dim extension As String
Dim entete As String
Dim nonLus As String
Dim memeNom As String
Dim ajouts As String
Dim vides As String
Dim dejaOuverts As String
Dim message As String
Dim ligneCible As Long
Dim nbFichiers As Long
Dim nbClasseurs As Long
Dim nbLignes As Long
Dim nbColonnes As Long
Dim nbEntetes As Long
Dim nbSortie As Long
Dim i As Long
Dim j As Long
Dim l As Long
Dim c As Long
Dim k As Long
Dim numeroErreur As Long
Dim texteErreur As String
Dim aReecrire As Boolean
Dim ajout As Boolean
Dim garder As Boolean
'À MODIFIER : le dossier à parcourir, par exemple "C:\Ventes\2026".
'Le séparateur final est retiré tout seul.
dossier = ""
On Error GoTo Echec
If Len(dossier) = 0 Then
Application.ScreenUpdating = True
Signaler "Consolider_classeurs_dossier", "renseignez la variable dossier dans le code."
Exit Sub
End If
Set destination = ActiveWorkbook
If destination Is Nothing Then
Application.ScreenUpdating = True
Signaler "Consolider_classeurs_dossier", "aucun classeur ouvert."
Exit Sub
End If
separateur = Application.PathSeparator
Do While Len(dossier) > 0 And (Right$(dossier, 1) = "\" Or Right$(dossier, 1) = "/")
dossier = Left$(dossier, Len(dossier) - 1)
Loop
'Les noms de fichiers se relèvent AVANT d'ouvrir quoi que ce soit : ouvrir un
'classeur au milieu d'une boucle Dir remet le parcours à zéro. Dir parcourt
'tout le dossier, sans caractère générique (l'aide de Microsoft les dit non
'pris en charge sur Mac), puis l'extension se teste. Le classeur de
'destination n'entre jamais dans la liste.
ReDim noms(1 To 16)
fichier = Dir$(dossier & separateur)
Do While Len(fichier) > 0
extension = ""
If InStrRev(fichier, ".") > 0 Then extension = LCase$(Mid$(fichier, InStrRev(fichier, ".") + 1))
If Left$(fichier, 2) <> "~$" _
And (extension = "xlsx" Or extension = "xlsm" Or extension = "xlsb" Or extension = "xls") _
And StrComp(dossier & separateur & fichier, destination.FullName, vbTextCompare) <> 0 Then
nbFichiers = nbFichiers + 1
If nbFichiers > UBound(noms) Then ReDim Preserve noms(1 To 2 * nbFichiers)
noms(nbFichiers) = fichier
End If
fichier = Dir$
Loop
If nbFichiers = 0 Then
Application.ScreenUpdating = True
Signaler "Consolider_classeurs_dossier", "aucun classeur dans " & dossier & "."
Exit Sub
End If
'L'ordre alphabétique des noms, sans tenir compte des majuscules : Dir rend
'celui du disque, qui change d'un poste ou d'un partage réseau à l'autre.
For i = 2 To nbFichiers
fichier = noms(i)
j = i - 1
Do While j >= 1
If StrComp(noms(j), fichier, vbTextCompare) <= 0 Then Exit Do
noms(j + 1) = noms(j)
j = j - 1
Loop
noms(j + 1) = fichier
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
For Each feuille In destination.Worksheets
If StrComp(feuille.Name, "Consolidation", vbTextCompare) = 0 Then Set cible = feuille
Next feuille
If cible Is Nothing Then
Set cible = destination.Worksheets.Add(After:=destination.Worksheets(destination.Worksheets.Count))
cible.Name = "Consolidation"
Else
cible.Cells.Clear
End If
ligneCible = 2
For i = 1 To nbFichiers
fichier = noms(i)
chemin = dossier & separateur & fichier
Set classeur = Nothing
Set aFermer = Nothing
'Excel n'ouvre jamais deux classeurs du même nom. Déjà ouvert depuis ce
'dossier, le classeur est lu tel quel ; ouvert depuis un autre dossier, il
'empêche de lire celui-ci, qui est sauté.
For Each ouvert In Application.Workbooks
If StrComp(ouvert.Name, fichier, vbTextCompare) = 0 Then Set classeur = ouvert
Next ouvert
If Not classeur Is Nothing Then
If StrComp(classeur.FullName, chemin, vbTextCompare) <> 0 Then
memeNom = memeNom & ", " & fichier
GoTo Suivant
End If
dejaOuverts = dejaOuverts & ", " & fichier
Else
'Un mot de passe quelconque fait échouer l'ouverture d'un classeur protégé
'au lieu d'afficher la boîte qui le demande, et un classeur sans mot de
'passe l'ignore. Un fichier qui ne s'ouvre pas est sauté.
On Error Resume Next
Set classeur = Workbooks.Open(Filename:=chemin, UpdateLinks:=0, ReadOnly:=True, _
Password:="?", IgnoreReadOnlyRecommended:=True)
numeroErreur = Err.Number
On Error GoTo Echec
If numeroErreur <> 0 Or classeur Is Nothing Then
nonLus = nonLus & ", " & fichier
GoTo Suivant
End If
Set aFermer = classeur
End If
If classeur.Worksheets.Count = 0 Then
nonLus = nonLus & ", " & fichier
GoTo Suivant
End If
Set plage = classeur.Worksheets(1).UsedRange
If Application.WorksheetFunction.CountA(plage) = 0 Then
vides = vides & ", " & fichier
GoTo Suivant
End If
'Les lignes de données, sans les lignes vides du bas, qu'une cellule mise en
'forme plus bas ajoute à la zone utilisée.
nbColonnes = plage.Columns.Count
nbLignes = 0
If plage.Rows.Count > 1 Then
valeurs = plage.Offset(1, 0).Resize(plage.Rows.Count - 1, nbColonnes).Value
If Not IsArray(valeurs) Then
ReDim tableau(1 To 1, 1 To 1)
tableau(1, 1) = valeurs
valeurs = tableau
End If
For l = UBound(valeurs, 1) To 1 Step -1
For c = 1 To nbColonnes
If IsError(valeurs(l, c)) Then
nbLignes = l
ElseIf Len(CStr(valeurs(l, c))) > 0 Then
nbLignes = l
End If
If nbLignes > 0 Then Exit For
Next c
If nbLignes > 0 Then Exit For
Next l
End If
'Chaque colonne rejoint la colonne de Consolidation qui porte le même en-tête,
'sans tenir compte des majuscules ni de l'ordre. Le premier classeur non vide
'donne les en-têtes ; un en-tête inconnu ajoute une colonne à droite, et le
'compte rendu nomme le fichier qui l'apporte.
If nbClasseurs = 0 Then cible.Cells(1, 1).Value = "Fichier source"
ReDim colonneCible(1 To nbColonnes)
ReDim prise(1 To nbEntetes + nbColonnes)
ajout = False
For c = 1 To nbColonnes
entete = Trim$(plage.Cells(1, c).Text)
k = 0
If nbClasseurs > 0 Then
If Len(entete) > 0 Then
For j = 1 To nbEntetes
If Not prise(j) Then
If StrComp(entetes(j), entete, vbTextCompare) = 0 Then
k = j
Exit For
End If
End If
Next j
ElseIf c <= nbEntetes Then
'Une colonne sans en-tête garde sa place si celle de Consolidation
'n'en a pas non plus.
If Not prise(c) And Len(entetes(c)) = 0 Then k = c
End If
End If
If k = 0 Then
'Une colonne sans en-tête ni donnée, comme une colonne seulement mise
'en forme, n'ajoute rien.
garder = (nbClasseurs = 0 Or Len(entete) > 0)
For l = 1 To nbLignes
If garder Then Exit For
If IsError(valeurs(l, c)) Then
garder = True
ElseIf Len(CStr(valeurs(l, c))) > 0 Then
garder = True
End If
Next l
If garder Then
nbEntetes = nbEntetes + 1
ReDim Preserve entetes(1 To nbEntetes)
entetes(nbEntetes) = entete
…