Discussion :

[ouskel'n'or]

Pour lister les 734 procedures d'un classeur où je mets tout un bazard, j'ai le code ci-après.
La liste alphabétique des macros, que j'obtiens avec ce code, est placée dans une feuille de calculs d'un classeur tout neuf.
Je souhaiterais, dans le classeur tout neuf, placer toutes les macros du "foure-tout" par ordre alpha.
Dans la première colonne j'ai le nom du module, dans la colonne B, le nom des macros.
Si quelqu'un a déjà fait ça, cela m'éviterait les tatonnements et je pourrais poursuivre mes activités normales

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CréerListeDesMacrosOrdreAlpha()
Dim Debut As Integer, Lignes As Integer
Dim Modul As Variant, NomMacro()
Dim i As Integer, Y As Integer
Dim X As Integer, ok As Boolean
Dim Cible As String
ScreenUpdating = False
Set Cl = Workbooks("FoureTout.xls")
    For i = 1 To Cl.VBProject.VBComponents.Count
        If Cl.VBProject.VBComponents(i).Type = 1 Then   'Limite aux modules (type = 1)
            Set Modul = Cl.VBProject.VBComponents(i).CodeModule
            With Modul
                For Y = 1 To .CountOfLines
                    Cible = Cl.VBProject.VBComponents(Modul).CodeModule.Lines(Y, 1)
                    Cible = Application.Substitute(Cible, " ", "")
                    ok = Len(Application.Substitute(Cible, "Sub", "")) < Len(Cible)
                    ok = ok And (Left(Cible, 3) = "Sub" Or Left(Cible, 7) = "Private")
                    ok = ok And (InStr(LCase(Cible), "click") = 0)
                    If ok Then
                        X = X + 1
                        Cells(X, 2) = Mid(Cl.VBProject.VBComponents(Modul).CodeModule.Lines(Y, 1), 5, Len(Cl.VBProject.VBComponents(Modul).CodeModule.Lines(Y, 1)) - 4)
                        bb = 1
                        ReDim Preserve NomMacro(bb, X)
                        NomMacro(bb, X) = Cells(X, 2).Formula
                        Cells(X, 1) = .Name
                    End If
                Next
            End With
        End If
    Next
    ActiveSheet.Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Set Cl = Nothing
End Sub

Je suggère à ceux qui vont me coder ça ( ) de partir de la liste alpha qui existe désormais dans mon classeur tout neuf, pour avoir l'ordre d'insersion.
Je sais que le code qui permet de récupérer le code d'une macro existe mais je ne l'ai pas retrouvé dans mon foutoir.
Par avance merci Michel, bbil, cafeine, AlainTech... et les autres

[helios77]

Bonjour,

Je ne connais pas la commande qui permet de lire du code mais peut être une alternative au problème

Pourquoi ne pas exporter manuellement les fichier.bas (en lesconvertissant en .txt si nécessaire) et ensuite des les traiter un apr un ?
En les lisant ligne à ligne, dès que l'on trouve le nom de la procédure, on les écrit dans un nouveau fichier jusqu'à ce que l'on trouve le end sub ou end function

Une fois que c'est finis, il usffirait de réimporter ce fichier dans Excel

Je suppose que cete manip est une manip occasionnelle

Je pense que çà peut être une bonne piste

[cafeine]

Hello,

si tu as le classeur, le module et le nom, tu peux aisément récupérer le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Public Function GetProcCode(ByVal Classeur As String, _
                            ByVal Module As String, _
                            ByVal Proc As String) As String
 
Dim wb As Workbook
Dim md As VBIDE.CodeModule
Dim i As Long
 
Set wb = Workbooks(Classeur)
Set md = wb.VBProject.VBComponents(Module).CodeModule
For i = 1 To md.CountOfLines
    If md.ProcOfLine(i, _
            vbext_pk_Get + vbext_pk_Let + vbext_pk_Proc + vbext_pk_Set) = Proc Then
       GetProcCode = GetProcCode & md.Lines(i, 1) & vbCrLf
    End If
Next i
Set md = Nothing
Set wb = Nothing
End Function

il ne te reste plus qu'à les insérer ...

[cafeine]

oops, ensuite insérer une proc :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Sub InsertCode(ByVal Classeur As String, _
                      ByVal Module As String, _
                      ByVal ProcCode As String)
 
Dim wb As Workbook
Dim md As VBIDE.CodeModule
Dim i As Long
 
Set wb = Workbooks(Classeur)
Set md = wb.VBProject.VBComponents(Module).CodeModule
 
md.AddFromString ProcCode
 
Set md = Nothing
Set wb = Nothing
End Sub

j'ai testé, ça semble marcher :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

InsertCode "Feuil4","Module1", GetProcCode("Foutoir.xls","UnModule","UneProc")

je n'ai pas mis en place de gestion d'erreur, à toi de jouer

[ouskel'n'or]

.......................
C'est ok ! Tout fonctionne au poil !
Au cas où ça intéresserait quelqu'un de classer ses macros et de connaître le code pour les identifier, pour identifier le nom des modules, je mets les deux macros qui m'ont servi pour obtenir "le classement de "738" macros (oui, 4 de plus que tout à l'heure...) par ordre alphabétique (+ de 10000 lignes de code).
La première crée la liste alphabétique inverse des modules et des macros, dans la feuille 1 du fichier destiné à recevoir les macros...
Peut être amélioré en ajoutant les fonctions

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

La seconde crée les modules et lance la copie des procédures.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CopierLesMacros()
Dim DerniereLigne As Integer, Destination As String, Proced As String, Origine As String
Dim Modul As String, i As Long, OldMod, Cl As Workbook, Fl As Worksheet, objM As VBComponent
Set Cl = Workbooks("FichierContenantLesMocrosAcopier.xls")
Set Fl = Cl.Worksheets("Feuil1") 'feuille dans laquelle se trouve la liste des macros
 
    Origine = "Perso_Save.xls"
    Workbooks.Add 'Crée le classeur dans lequel les macros seront copiées
    Destination = ActiveWorkbook.Name 'le fichier créé
    DerniereLigne = Fl.Range("A1").SpecialCells(xlCellTypeLastCell).Row
    'Dernière ligne de la liste des macros
 
    For i = 1 To DerniereLigne 'lecture des noms ds modules et de procédures
 
        On Error Resume Next
 
            OldMod = Modul 'Mémo dernier module créé
            Modul = Fl.Cells(i, 1) 'Lecture du nom du module
 
            If Modul <> OldMod Then ' si le nom est différent, on crée le nouveau module
                Set objM = Application.VBE.ActiveVBProject.VBComponents.Add(vbext_ct_StdModule)
                objM.Name = Modul
                Set objM = Nothing
            End If
 
            Proced = Fl.Cells(i, 2) 'lecture du nom de la macro
            InsertCode Destination, Modul, GetProcCode(Origine, Modul, Proced)
 
        If Err <> 0 Then Cells(i, 3).Value = Error(Err) & " No " & Err & " sur macro " & Proced
        Err.Clear
 
    Next
 
Set Cl = Nothing
Set Fl = Nothing
End Sub

Mille merci cafeine !

Edit
Pour copier les déclarations (ce que fait pas le code précédent, ici, cafeine, l'incollable, donne la solution