Option Explicit 'déclaration des variables obligatoire
Dim lig&, dico As Object 'mémorise les variables
Sub FichiersAvecMacros_5_niveaux_d_imbrication()
Dim chemin$, chem1$, chem2$, chem3$, chem4$, chem5$
Dim niveau1$(), niveau2$(), niveau3$(), niveau4$(), niveau5$()
Dim dossier1, dossier2, dossier3, dossier4, dossier5
'---initialisation---
chemin = ThisWorkbook.Path 'chemin du 1er niveau
lig = 2
Application.ScreenUpdating = False
[A:C].ClearContents 'RAZ
[A1] = "MACRO": [B1] = "DOSSIER": [C1] = "FICHIER"
'---listes des sous-dossiers---
SousDossiers chemin, niveau1
For Each dossier1 In niveau1
chem1 = chemin & "\" & dossier1
SousDossiers chem1, niveau2
For Each dossier2 In niveau2
chem2 = chem1 & "\" & dossier2
SousDossiers chem2, niveau3
For Each dossier3 In niveau3
chem3 = chem2 & "\" & dossier3
SousDossiers chem3, niveau4
For Each dossier4 In niveau4
chem4 = chem3 & "\" & dossier4
SousDossiers chem4, niveau5
Next dossier4, dossier3, dossier2, dossier1
'---fichiers du dossier et des sous-dossiers---
Set dico = CreateObject("Scripting.Dictionary")
Fichiers chemin
For Each dossier1 In niveau1
chem1 = chemin & "\" & dossier1
Fichiers chem1
For Each dossier2 In niveau2
chem2 = chem1 & "\" & dossier2
Fichiers chem2
For Each dossier3 In niveau3
chem3 = chem2 & "\" & dossier3
Fichiers chem3
For Each dossier4 In niveau4
chem4 = chem3 & "\" & dossier4
Fichiers chem4
For Each dossier5 In niveau5
chem5 = chem4 & "\" & dossier5
Fichiers chem5
Next dossier5, dossier4, dossier3, dossier2, dossier1
Columns.AutoFit
End Sub
Sub SousDossiers(chemin$, niveau$())
Dim dossier$, n&
dossier = Dir(chemin & "\*", vbDirectory)
On Error Resume Next
If IsError(niveau(0)) Then ReDim niveau(0) Else n = UBound(niveau) + 1
On Error GoTo 0
While dossier <> ""
If GetAttr(chemin & "\" & dossier) = vbDirectory And dossier <> "." And dossier <> ".." Then
ReDim Preserve niveau(n)
niveau(n) = dossier
n = n + 1
End If
dossier = Dir
Wend
End Sub
Sub Fichiers(chemin$)
Dim dossier$, fichier$, fich$, test As Boolean
dossier = Mid(chemin, InStrRev(chemin, "\") + 1)
If dossier = "" Then Exit Sub
fichier = Dir(chemin & "\*xls")
While fichier <> ""
fich = LCase(chemin & "\" & fichier)
If Not dico.exists(fich) Then 'élimine les doublons
dico(fich) = ""
If fichier <> ThisWorkbook.Name Then
On Error Resume Next
Workbooks(fichier).Close False 'si un fichier du même nom est ouvert
On Error GoTo 0
Workbooks.Open fich
test = ContientMacros(Workbooks(fichier))
Workbooks(fichier).Close False
If test Then Cells(lig, 1) = "OUI"
Cells(lig, 2) = dossier
Cells(lig, 3) = fichier
lig = lig + 1
End If
End If
fichier = Dir
Wend
End Sub
Function ContientMacros(Wb As Workbook) As Boolean
Dim o As Object
For Each o In Wb.VBProject.VBComponents
With o.CodeModule
ContientMacros = .CountOfDeclarationLines + 1 < .CountOfLines
End With
If ContientMacros Then Exit For
Next
End Function
b75... C'est superbe !
