1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
| Sub MacrosCréerListeDansClasseur()
Dim Modul As Variant, i As Integer, Y As Integer, X As Integer, ok As Boolean
Dim Cible As String, Cl As Workbook, Ft As Worksheet
Set Cl = Workbooks("FichierContenantLesMocrosAcopier.xls")
Set Ft = Cl.Worksheets("Feuil1") 'feuille dans laquelle est placée la liste des macros...
'... et des modules
For i = 1 To Cl.VBProject.VBComponents.Count
If Cl.VBProject.VBComponents(i).Type = 1 Then 'Limité aux modules (type = 1)
'sont exclus les userform et les modules de classe
Set Modul = Cl.VBProject.VBComponents(i).CodeModule
With Modul
For Y = 1 To .CountOfLines 'Parcours des modules à la recherche des sub
Cible = Cl.VBProject.VBComponents(Modul).CodeModule.Lines(Y, 1)
ok = Len(Application.Substitute(Cible, "Sub", "")) < Len(Cible)
ok = ok And (Left(Cible, 3) = "Sub" Or Left(Cible, 7) = "Private")
'ici on peut ajouter les fonctions si on le désire
ok = ok And (InStr(LCase(Cible), "click") = 0)
If ok Then
X = X + 1
'le nom des macros est nettoyé de ses "appendices"
Cible = Application.Substitute(Cible, "Private ", "")
Cible = Application.Substitute(Cible, "Sub ", "")
Cible = Application.Substitute(Cible, " ", "")
Cible = Left(Cible, InStr(Cible, "(") - 1)
Ft.Cells(X, 2) = Cible
Ft.Cells(X, 1) = .Name
End If
Next
End With
End If
Next
Ft.Range("A1").CurrentRegion.Sort Key1:=Range("A1"), _
Order1:=xlDescending, Key2:=Range("B1"), Order2:=xlDescending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set Cl = Nothing
Set Ft = Nothing
End Sub |
Partager