Simplification d'une macro

**teddy72000** · 29/01/2011, 11h25

Bonjour j'ai fait une macro qui fait du calcul avec une fonction copier en fonction du mois.

J'ai tout fais avec l'enregistreur, j'ai déjà supprimé pas mal de ligne inutiles.

Est-il possible de simplifier encore le code, je suis novice

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
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
' Macro1 Macro
' Macro enregistrée le 28/01/2011 par yxk478'
    'arret des messages du presse-papier
 
    Application.DisplayAlerts = False
 
    'copie du fichier
 
    Windows("default").Activate
    Range("A1:F300").Copy
    Windows("classeur1.xls").Activate
    Sheets("Data").Select
    Range("A1").Select
    ActiveSheet.Paste
 
    'Fermeture du classeur
    Windows("default.xls").Activate
    ActiveWindow.Close SaveChanges:=True
 
   'Création colonne Duree activite Abs avec calcul
 
    Range("F2").FormulaR1C1 = "=RC[-1]*24"
    Range("F2").AutoFill Destination:=Range("F2:F300"), Type:=xlFillDefault
    Range("F2:F300").NumberFormat = "0.00"
 
    'Parametres format celulles
 
    Range("I8:I15").NumberFormat = "0.00"
 
    'Calcul trajet
 
    Range("I14").FormulaR1C1 = "=SUM(R[-6]C[-5]:R[300]C[-5])"
 
    'Calcul Ticket CAC
 
    Range("J20").Value = "=SUMPRODUCT((B2:B300>2000)*1)"
 
    Range("J21").Value = "=SUMPRODUCT((B2:B300=""NULL"")*1)"
 
    Range("I15").Value = Range("J20").Value - Range("J21").Value
 
    'Calcul INDUS PREVE
    Range("A1:F1").AutoFilter
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1, Criteria1:= _
        "PREVENTIF"
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=3, Criteria1:="=*ttf*" _
        , Operator:=xlAnd
    Columns("A:F").Copy
    Sheets("Data2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("H11").Select
    ActiveCell.FormulaR1C1 = "=SUM(C[-2])"
    Range("H11").Copy
 
    Sheets("Data").Select
    Range("I11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=3
 
    Sheets("Data2").Select
    Cells.ClearContents
    Sheets("Data").Select
 
    'Calcul INDUS CUR
 
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1, Criteria1:= _
        "CORR-SITE"
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=3, Criteria1:="=*ttf*" _
        , Operator:=xlAnd
    Columns("A:F").Copy
    Sheets("Data2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("H20").FormulaR1C1 = "=SUM(C[-2])"
    Range("H20").Copy
    Sheets("Data").Select
    Range("I12").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=3
    Sheets("Data2").Select
    Cells.ClearContents
    Sheets("Data").Select
 
    Range("I13").Value = Range("I12") + Range("I11")
 
    'Calcul corr-distance assitance
 
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1, Criteria1:= _
        "=CORR-ASSIST", Operator:=xlOr, Criteria2:="=CORR-DISTANCE"
    Columns("A:F").Copy
    Sheets("Data2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("H8").FormulaR1C1 = "=SUM(C[-2])"
    Range("H8").Copy
    Sheets("Data").Select
    Range("I8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1
    Sheets("Data2").Select
    Cells.ClearContents
    Sheets("Data").Select
 
    'Calcul Corr-site hors corr-distance corr-assist hors ttf
 
     ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1, Criteria1:=Array( _
        "CORR-INJUST", "CORR-SITE", "DEP-INST-DESINST", "DEP-MISE-A-NIVEAU", "ETUDES-TECH", _
        "PREP-ATELIER", "PREVENTIF", "="), Operator:=xlFilterValues
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=3, Criteria1:="<>*ttf*" _
        , Operator:=xlAnd
 
        Columns("A:F").Copy
    Sheets("Data2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("H10").FormulaR1C1 = "=SUM(C[-2])"
    Range("H10").Copy
    Sheets("Data").Select
     Range("I9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=1
    ActiveSheet.Range("$A$1:$F$300").AutoFilter Field:=3
 
    Sheets("Data2").Select
    Cells.ClearContents
    Sheets("Data").Select
 
    Range("I10").Value = Range("I8") + Range("I9")
 
    'demande du mois à traiter
 
  Dim Reponse As String
  Reponse = InputBox("Quel est le mois à traiter?")
 
  Range("N1").Value = Reponse
 
  Range("I8:I15").Copy
    Range("L5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Selection.NumberFormat = "0.00"
 
  'Copie dans feuille 1
 
Dim CelCible As Range
Dim Mois As String
 
  Mois = Right(Worksheets("Data").Range("N1"), 9)
  Set CelCible = Worksheets("Feuil1").Range("a:a").Find(what:=Mois, LookIn:=xlValues, lookat:=xlWhole)
  If Not CelCible Is Nothing Then
    Worksheets("Data").Range("L5:S5").Copy CelCible(1, 2)
  End If  
 
  'Reparametrage tableau
 
  Sheets("Feuil1").Select
  Range("B2:I14").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
 
   'Suppression des données dans data
 
    Sheets("Data2").Select
    Cells.ClearContents
    Range("A1").Select
 
 
    Sheets("Data").Select
    Cells.ClearContents
    Range("A1").Select   
 
    Sheets("Feuil1").Select
    Range("A1").Select
 
    'Affichage message apres traitement
    MsgBox "Traitement Terminé", vbOKOnly + vbInformation, "Traitement Données"
 
 
End Sub

merci pou votre coup de main!!!!!!!!!!!!!

**Theze** · 29/01/2011, 14h11

Bonjour Teddy72000,

Avec toutes les actions que tu effectue, on peut difficilement plus réduire le code mais teste ce qui est ci-dessous car je n'ai fait aucun test. Quelqu'un te donnera sûrement encore quelques astuces :

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
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
 
Sub Macro1()
 
    Dim FeData As Worksheet
    Dim FeData2 As Worksheet
    Dim CelCible As Range
    Dim Mois As String
    Dim Reponse As String
 
    'arret des messages du presse-papier
    Application.DisplayAlerts = False
 
    Set FeData = Workbooks("classeur1.xls").Worksheets("Data")
    Set FeData2 = Workbooks("classeur1.xls").Worksheets("Data2")
 
    With FeData
        'copie du fichier
        Worksheets("default").[A1:F300].Copy .Range("A1")
 
        'Fermeture du classeur
        Workbooks("default.xls").Close True
 
        'Création colonne Duree activite Abs avec calcul
        .[F2:F300].FormulaR1C1 = "=RC[-1]*24"
        .[F2:F300].NumberFormat = "0.00"
 
        'Parametres format celulles
        .[I8:I15].NumberFormat = "0.00"
 
        'Calcul trajet
        .[I14].FormulaR1C1 = "=SUM(R[-6]C[-5]:R[300]C[-5])"
 
        'Calcul Ticket CAC
        .[J20].Value = "=SUMPRODUCT((B2:B300>2000)*1)"
        .[J21].Value = "=SUMPRODUCT((B2:B300=""NULL"")*1)"
        .[I15].Value = [J20] - [J21]
 
        'Calcul INDUS PREVE
        .[A1:F1].AutoFilter 'affiche les flêches
        .[A1:F300].AutoFilter 1, "PREVENTIF"
        .[A1:F300].AutoFilter 3, "=*ttf*", xlAnd
        .Columns("A:F").Copy Worksheets("Data2").[A1]
 
        FeData2.Range("H11").FormulaR1C1 = "=SUM(C[-2])"
        FeData2.Range("H11").Copy Fe.[I11]
 
        .[A1:F300].AutoFilter 1
        .[A1:F300].AutoFilter 3
 
        FeData2.Cells.ClearContents
 
        'Calcul INDUS CUR
        .[A1:F300].AutoFilter 1, "CORR-SITE"
        .[A1:F300].AutoFilter 3, "=*ttf*", xlAnd
 
        Columns("A:F").Copy Worksheets("Data2").[A1]
 
        FeData2.[H20].FormulaR1C1 = "=SUM(C[-2])"
        FeData2.[H20].Copy .[I12]
 
        .[A1:F300].AutoFilter 1
        .[A1:F300].AutoFilter 3
 
        FeData2.Cells.ClearContents
 
        .[I13] = .[I12] + .[I11]
 
 
        'Calcul corr-distance assitance
        .[A1:F300].AutoFilter 1, "=CORR-ASSIST", xlOr, "=CORR-DISTANCE"
        .Columns("A:F").Copy FeData2.[A1]
 
        FeData2.[H8].FormulaR1C1 = "=SUM(C[-2])"
        FeData2.[H8].Copy .[I8]
        .[A1:F300].AutoFilter 1
        FeData2.Cells.ClearContents
 
        'Calcul Corr-site hors corr-distance corr-assist hors ttf
        .[A1:F300].AutoFilter 1, Array("CORR-INJUST", "CORR-SITE", "DEP-INST-DESINST", _
                                       "DEP-MISE-A-NIVEAU", "ETUDES-TECH", "PREP-ATELIER", "PREVENTIF", "="), xlFilterValues
        .[A1:F300].AutoFilter 3, "<>*ttf*", xlAnd
 
        .Columns("A:F").Copy FeData2.[A1]
        FeData2.[H10].FormulaR1C1 = "=SUM(C[-2])"
        FeData2.[H10].Copy FeData.[I9]
 
        .[A1:F300].AutoFilter 1
        .[A1:F300].AutoFilter 3
 
        FeData2.Cells.ClearContents
 
        .[I10] = .[I8] + .[I9]
 
        'demande du mois à traiter
 
        Reponse = InputBox("Quel est le mois à traiter?")
 
        .[N1] = Reponse
        .Range("I8:I15").Copy .Range("L15")
        .[I8:I15].Copy
        .[L5].PasteSpecial xlPasteValues, , , True
        .[L5].NumberFormat = "0.00"
 
        'Copie dans feuille 1
        Mois = Right(.[N1], 9)
        Set CelCible = Worksheets("Feuil1").Range("a:a").Find(Mois, xlValues, xlWhole)
 
        If Not CelCible Is Nothing Then
          .[L5:S5].Copy CelCible(1, 2)
        End If
 
        'Suppression des données dans data
        FeData2.Cells.ClearContents
 
        .Cells.ClearContents
 
    End With
 
    'Reparametrage tableau
    With Sheets("Feuil1").Range("B2:I14")
 
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
 
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
 
    End With
 
    Sheets("Feuil1").Select
 
    Application.DisplayAlerts = True
 
    'Affichage message apres traitement
    MsgBox "Traitement Terminé", vbOKOnly + vbInformation, "Traitement Données"
 
End Sub

Hervé.

**Qwazerty** · 29/01/2011, 16h14

Salut
J'ai vu quelques Select/Selection qui traînent, il faut les supprimer

, sauf si tu veux effectivement sélectionner une cellule particulière pour un aspect visuel lorsque l'utilisateur regarde la feuille une fois la macro terminé.

Pour ta mise en forme de tableau

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
  'Reparametrage tableau
  With Sheets("Feuil1").Range("B2:I14")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    With .Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    .BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
  End With

[Edit]
Quelques conseils.
Déclare toutes tes variables en début de code, pas juste au moment ou tu en a besoin.

Il faut supprimer les Select / Selection

Code :

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

1
2
3
4
    With Sheets("Data2")
        .Cells.ClearContents
        .Range("A1").Select
    End With

Sinon pour ce qui est de l'utilisation de ActiveSheet, il est préférable d'utiliser des variable WorkSheet qui représentent les différentes feuilles (ça évite bien des erreur), Theze te montre comment faire dans sont code avec l'utilisation en prime de With.

[/Edit]
++
Qwaz

**teddy72000** · 30/01/2011, 23h17

slt, merci,

j'ai essayé mais cela ne fonctionne pas, si quelqu'un a d'autres propositions

**Qwazerty** · 31/01/2011, 01h47

Salut
"Ca ne fonctionne pas", c'est a dire?

Si j'isole ton code qui fait la mise en page, que je l'exécute sur une feuille et que j’exécute le mien sur une autre, j'ai bien la même organisation.
Donc il serait bien d'en dire un peu plus.
Même si le code que je te donne ne fait pas exactement ce que tu veux, tu devrais pouvoir t'en inspirer pour simplifier ton écriture.

Tu as suivi nos conseils? tu as supprimé les Select et Selection qui ne sont pas utiles? Poste ton nouveau code.

++
Qwaz

**teddy72000** · 24/02/2011, 19h48

merci beaucoup

Simplification d'une macro

Macros et VBA Excel

Discussions similaires

Partager

Partager