Option Explicit
Dim ListeDossiers$() 'mémorise la variable
Sub FichiersAvecMacros()
Dim chemin As Variant, lig&, col%, sbar As Boolean
Dim debut&, dossier$, fichier$, test As Boolean, compte&
'---initialisation---
chemin = ThisWorkbook.Path
lig = 2: col = 1
sbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True 'affichage de la barre d'état
Cells.Delete 'RAZ
Cells(1, col).Resize(, 4) = Array("N°", "MACRO", "DOSSIER", "FICHIER")
Columns.AutoFit
Rows(1).Font.Bold = True 'gras
Rows(1).Font.Color = vbBlue
'---liste des dossiers---
ReDim ListeDossiers(0)
ListeDossiers(0) = chemin
If MsgBox("Voulez-vous traiter les sous-dossiers ?", 4) = 6 _
Then SousDossiers CStr(chemin), 1
'---analyse des fichiers---
Application.ScreenUpdating = False
debut = InStrRev(ListeDossiers(0), "\") + 1
For Each chemin In ListeDossiers
dossier = Mid(chemin, debut) 'chemin à partir du 1er dossier
fichier = Dir(chemin & "\*xls")
While fichier <> ""
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 chemin & "\" & fichier
test = ContientMacros(Workbooks(fichier))
Workbooks(fichier).Close False
compte = compte + 1 'compteur
Application.StatusBar = compte
Cells(lig, col) = compte
If test Then Cells(lig, col + 1) = "OUI"
Cells(lig, col + 2) = dossier
Cells(lig, col + 3) = fichier
lig = lig + 1
If lig = Rows.Count Then 'limite de la feuille, nouvelles colonnes
lig = 2
col = col + 4
Cells(1, col).Resize(, 4) = Array("N°", "MACRO", "DOSSIER", "FICHIER")
End If
End If
fichier = Dir
Wend
Next
Columns.AutoFit
Application.DisplayStatusBar = sbar
End Sub
Sub SousDossiers(chemin$, n&)
Dim fso As Object, dossier As Object, sd As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set dossier = fso.GetFolder(chemin)
For Each sd In dossier.subfolders
ReDim Preserve ListeDossiers(n)
ListeDossiers(n) = sd.Path
n = n + 1
SousDossiers sd.Path, n 'méthode récursive
Next
Set fso = Nothing
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
)
