Automatisation de modifications de macros

Version imprimable

Bonjour,
N'étant pas expert Office je me retrouve bloqué sur un problème Excel.
Je dois modifier des macros dans environs 140 fichiers Excel (environs 8000 feuilles).
Ces feuilles contiennes 3 boutons et je dois modifier les macros de ces 3 boutons sur tout les fichiers.
Les modifications sont toutes les mêmes, je dois rajouter les commandes suivantes :
Code:

1 2 3 4 5 6 7 8 ' au début de chaque action : Application.Calculation = xlCalculationManual [Mon Code] ' puis le réactiver à la fin et relancer un calcul : Application.Calculation = xlCalculationAutomatic ActiveSheet.Calculate
Sachant que chaque fichier a un nom différents et les feuilles n'ont pas toutes le même nom...

Ça fait un petit moment que je cherche donc une solution pour automatiser cela et ne pas passer sur 8000 feuilles manuellement.

Merci d'avance.

Bonne année à tous le monde !

03/01/2019, 19h17
Theze

Bonjour,

Montre ton code pour voir comment insérer ces lignes !

Bonjour,

Je peux vous mettre le code d'un des boutons mais le code en lui même ne change rien sachant que ça change sur chaque feuilles et je suis pas sure que vous vouliez voir les codes des 8000 feuilles ;)

Voici un des boutons (ligne 3, 51 et 52 ce que je dois rajouter sur les 3 macros (de 3 boutons) de toutes les feuilles d'un des fichier Excel):

Code:

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
51
52
53
54
Private Sub CommandButton4_Click()
 
Application.Calculation = xlCalculationManual
 
Range("A30").Select
nblignes = Range("A30", Selection.End(xlDown)).Cells.Count
q = 29 + nblignes
 
derncol = Range("A30").End(xlToRight).Column
dercol = derncol + 2
avdercol = derncol + 1
dcol = Split(Columns(dercol).Address(ColumnAbsolute:=False), ":")(1)
avcol = Split(Columns(avdercol).Address(ColumnAbsolute:=False), ":")(1)
col = Split(Columns(derncol).Address(ColumnAbsolute:=False), ":")(1)
 
Columns(avcol & ":" & dcol).Insert Shift:=xlToRight
 
celltxt = Range(col & "30").Value
cellval = Right(celltxt, 1) + 1
 
Range(avcol & "30") = "Versement VS  - " & cellval
Range(avcol & "31:" & avcol & q).NumberFormat = "#,##0.00 €"
 
Range(dcol & "30") = "Date versement VS  - " & cellval
Range(dcol & "31:" & dcol & q).NumberFormat = "dd/mm/yy"
Range(avcol & "30:" & dcol & "30").HorizontalAlignment = xlCenter
Range(avcol & "30:" & dcol & "30").VerticalAlignment = xlVAlignCenter
Range(avcol & "30:" & dcol & "30").Font.ColorIndex = 1
Range(avcol & "30:" & dcol & "30").WrapText = True
 
derncola = Range("A30").End(xlToRight).Column
dcola = Split(Columns(derncola).Address(ColumnAbsolute:=False), ":")(1)
Columns("W:" & dcola).ColumnWidth = 17
Range("W30:" & dcola & "30").Borders.LineStyle = 1
 
f = 31
 
Do While f <= q
    val1 = Range("V" & f).FormulaLocal
val1 = Replace(val1, ";2)", "")
    Range("V" & f).FormulaLocal = val1 & "-" & avcol & f & ";2)"
    f = f + 1
Loop
 
formul1 = Range("H16").Formula
formul2 = Len(formul1)
formul2 = formul2 - 1
formul3 = Left(formul1, formul2)
Range("H16").Formula = formul3 & "," & avcol & "31:" & avcol & q & ")"
 
Application.Calculation = xlCalculationAutomatic
ActiveSheet.Calculate
 
End Sub

Merci d'avance.

Bonne journée.

04/01/2019, 17h23
jpvba

Bonjour à vous,

SVP utiliser les balises # pour votre code :merci:

Personnellement j'aurais adapté le code afin d'avoir un seul et unique code pour l'ensemble des feuilles mais connaissant pas votre besoins réel, je ne sais pas si cela est faisable.

Également si le code n'Est pas utilisé par d'autre personne j'aurais stocké le tout dans le personal.xlsb afin de gérer le code à un seul et unique endroit
06/01/2019, 08h52
unparia

Bonjour
Une chose me paraît certaine (si l'on s'en tient au voeu exprimé, tel qu'exprimé) --->>

Citation:

Ces feuilles contiennes 3 boutons et je dois modifier les macros de ces 3 boutons sur tout les fichiers.
Les modifications sont toutes les mêmes, je dois rajouter les commandes suivantes :
.......
......
Sachant que chaque fichier a un nom différents et les feuilles n'ont pas toutes le même nom...

= mission impossible, sauf si, à la fois, chacun de ces 3 boutons porte toujours le même nom dans chaque classeur et que ce nom est unique au sein de chaque classeur ! Et si ces deux conditions sont réunies : en ramant sec ...

Bonjour,

Voici un code qui fait ce que tu demandes mais je te conseille, pour le test, de ne mettre que 4 ou 5 copies de tes classeurs dans un dossier provisoire et de lancer la procédure "Remplacer" pour voir le résultat. Je te conseille fortement de faire plusieurs tests sur de petits paquets de copies de classeurs et de bien contrôler si le résultat obtenu correspond bien à tes souhaits car traficoter du code par VBA n'est pas anodin et sur 8000 classeurs si les résultats obtenus ne sont pas ceux souhaité, je te laisse imaginer les heures de travail pour remettre tout ça en ordre donc, prudence :

Code:

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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
 
Sub Remplacer()
 
    Dim Cl As Workbook
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As Integer
 
    Chemin = Dossier
 
    If Chemin = "" Then Exit Sub
 
    'appel de la fonction...
    Tbl() = RecupFichiers(Chemin)
 
    'si le tableau a été initialisé...
    If Not Not Tbl Then
 
        For I = 1 To UBound(Tbl)
 
            'ouverture de tous les classeurs...
            Set Cl = Workbooks.Open(Tbl(I))
 
            'insertion des lignes
            Inserer Cl
 
            'fermeture avec enregistrement des modifs
            Cl.Close True
 
        Next I
 
    End If
 
End Sub
 
Function RecupFichiers(Chemin As String) As String()
 
    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer
 
    'récupère tous les classeurs dun dossier dans un tableau
    Fichier = Dir(Chemin & "*.xls*")
 
    Do While (Len(Fichier) > 0)
 
        I = I + 1
 
        ReDim Preserve TableauFichiers(1 To I)
 
        TableauFichiers(I) = Chemin & Fichier
 
        Fichier = Dir()
 
    Loop
 
    RecupFichiers = TableauFichiers()
 
End Function
 
Function Dossier() As Variant
 
    'sélection du dossier contenant les classeurs
    With Application.FileDialog(4)
        If .Show = -1 Then Dossier = .SelectedItems(1) & "\"
    End With
 
End Function
 
Sub Inserer(Classeur As Workbook)
 
    Dim mModule As Object
    Dim I As Integer
    Dim J As Integer
    Dim Proc As String
 
    'les * pour prendre en compte les espaces et commentaires
    Proc = "*Private Sub *_Click()*"
 
    'parcours la collection de module mais ne s'arrête que su les module de feuilles et classeur
    'et effectue les insertions
    For Each mModule In Classeur.VBProject.VBComponents
 
        If mModule.Type = 100 Then
 
            With mModule.CodeModule
 
                J = 0
 
                Do
                    J = J + 1
 
                    If .Lines(J, 1) Like Proc Then
 
                        .InsertLines J + 1, vbCrLf & _
                                            "Application.Calculation = xlCalculationManual" & _
                                            vbCrLf
 
                        J = J + 3
 
                    End If
 
                    If .Lines(J, 1) Like "*End Sub*" Then
 
                        .InsertLines J, vbCrLf & _
                                        "Application.Calculation = xlCalculationAutomatic" & _
                                        vbCrLf & _
                                        "ActiveSheet.Calculate" & _
                                        vbCrLf
 
                        J = J + 4
 
                    End If
 
                Loop While J < .CountOfLines
 
            End With
 
        End If
 
    Next mModule
 
End Sub