Discussion :

[FFGUY]

Bonjour,

J aimerais optimiser ma macro, elle fonctionne tres bien mais je suis conscient qu il y a pleins de choses qui pourrait etre ameliorer.
J en appelle donc a un oeil expert, pour me promouvoir de precieux conseils.
Merci d avance.

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
 
Sub TOP_Clients()
'
' TOP_Clients Macro
' Macro recorded 04/03/2013 by ut1s4g
'
NbSheet = Sheets.Count
For i = 2 To NbSheet
If Sheets(i).Range("A1").Value = "Present Month" Then
T = i + 1
Sheets(T).Activate
    If Not IsEmpty(Sheets(T).Range("A1")) Then
    If Not Sheets(T).Range("A1") = "Present Month" Then
    LastRaw = Range("A65536").End(xlUp).Row - 2
    Rows("4:4").Select
    Selection.AutoFilter
    Range("A4:U283").Sort Key1:=Range("G4"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Rows("4:4").Select
    Selection.AutoFilter
    Range("U:U,F:F,E:E").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Range("A:A").Select
    Selection.Font.ColorIndex = 0
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("A5:A6").Select
    Selection.AutoFill Destination:=Range("A5:A" & LastRaw)
    Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A2").Formula = "=MID(B1,43,2)- MID(B1,32,2)"
    Range("B2").Formula = "=MID(B1,40,2)-MID(B1,29,2)"
    Range("C2").Formula = "=IF(AND(B2=0,A2>27,A2<32),0,1)"
    Range("C2").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        If Range("C2") = "1" Then
        MsgBox "Please select no more or less than a month!", vbOKOnly, "Wrong Date Range"
        Cells.Select
        Selection.Delete
        Else
        End If
        Range("A2:C2").Select
        Selection.ClearContents
        Columns("B:B").Select
        Selection.Insert Shift:=xlToRight
        Columns("B:B").Select
        Selection.Insert Shift:=xlToRight
        Range("B4").Select
        ActiveCell.FormulaR1C1 = "Last Month"
        Range("C4").Select
        ActiveCell.FormulaR1C1 = "Progression"
        Range("A4").Select
        ActiveCell.FormulaR1C1 = "Present Month"
        Range("D4").Select
        Selection.Copy
        Range("A4:C4").Select
        Range("C4").Activate
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
           SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
 
            If ActiveSheet.Name = "Jan" Then
            Range("B5").Select
            ActiveCell.FormulaR1C1 = "N/A"
            Selection.AutoFill Destination:=Range("B5:B" & LastRaw)
            Range("C5").Select
            ActiveCell.FormulaR1C1 = "N/A"
            Selection.AutoFill Destination:=Range("C5:C" & LastRaw)
            Range("G:G,K:U").Select
             Selection.Delete Shift:=xlToLeft
            Range("1:3").Select
             Selection.Delete Shift:=xlToUp
            Else
            End If
For K = 2 To LastRaw - 3
    For j = 2 To Sheets(ActiveSheet.Index - 1).Range("A65536").End(xlUp).Row
                If Range("D" & K) = Sheets(ActiveSheet.Index - 1).Range("D" & j) Then
                Range("B" & K) = Sheets(ActiveSheet.Index - 1).Range("A" & j)
                End If
                Next j
                Next K
 
Range("G:G,K:U").Select
Selection.Delete Shift:=xlToLeft
Range("1:3").Select
Selection.Delete Shift:=xlToUp
For m = 2 To LastRaw - 3
Range("C" & m) = Range("B" & m) - Range("A" & m)
Next m
Range("C2:C" & LastRaw - 3).Select
    Selection.NumberFormat = "+0_ ;[Red]-0 "
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
                    For l = 2 To LastRaw - 3
                    If Range("B" & l) = "" Then
                    Range("C" & l).ClearContents
                    Range("C" & l) = "NEW"
                    Range("A" & l & ":I" & l).Interior.Color = RGB(174, 240, 194)
                    End If
                    Next l
                    MsgBox "Ranking has been processed", VbOnly, "Job Done"
    Else
    MsgBox "No Data has been copied !"
    End If
 
    End If
Else
End If
Next i
Sheets(1).Activate
End Sub

[Philippe Tulliez]

Bonjour,
La toute première chose à faire est déjà de supprimer toutes les commandes Select, Selection, Activate etc... et remplacer par un accès direct aux objets cellules.

[mikadoo57]

Je pense que FFGUY est comme moi, la méthode select ou activate est une procédure pas à pas qui permet de combler les lacunes d'une syntaxe plus élaborée
Je crois qu'il y a un tuto qui aborde ce sujet mais sans trop entrer dans le détail, en particulier en donnant des exemples concrets sur le modèle "avant" et "après". Il serait peut-être intéressant de faire tuto "pour les nuls" ?

[FFGUY]

Bonjour,

J ai essaye d ameliorer le code mais je pense qu il est encore possible de l optimiser.
Pour donner un peu de contexte la macro sert a classer des client selon 1 critere, mes 3 premieres colonnes me donnent le classement du mois le deuxieme celui du mois d avant et la troisieme la progression.
De plus si un client n etait pas dans le classement le mois d avant il est affiche en couleur.
Dans chacune des Tabs ca fonctionne bien mais le resume de l annee que j essaye de creer sur la premiere page ne s affiche pas ?
Qqun aurait il une idee de ce qui ne va pas dans mon 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
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
Sub TOP_Clients()
 
Application.ScreenUpdating = False
NbSheet = Sheets.Count
 
'Check the sheet is not already formated or not the last one
For i = 2 To NbSheet
If Sheets(i).Range("A1").Value = "Present Month" Then
T = i + 1
    If T < NbSheet Then
    Sheets(T).Activate
        If Not IsEmpty(Sheets(T).Range("A1")) Then
            If Not Sheets(T).Range("A1") = "Present Month" Then
            LastRaw = Range("A65536").End(xlUp).Row - 2
            'We sort by executed Volume & start formatting
            Rows("4:4").Select
            Selection.AutoFilter
             Range("A4:U" & LastRaw).Sort Key1:=Range("G4"), Order1:=xlDescending, Header:= _
             xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
             DataOption1:=xlSortNormal
            Rows("4:4").Select
            Selection.AutoFilter
             Range("U:U,F:F,E:E").Delete Shift:=xlToLeft
             Columns("A:A").Insert Shift:=xlToRight
             Range("A:A").Font.ColorIndex = 0
            Range("A5").FormulaR1C1 = "1"
            Range("A6").FormulaR1C1 = "2"
            Range("A5:A6").AutoFill Destination:=Range("A5:A" & LastRaw)
            Range("A5").Select
            Range(Selection, Selection.End(xlDown)).Font.Bold = True
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            'Check the selection is not more or less than a month
            Range("A2").Formula = "=MID(B1,43,2)- MID(B1,32,2)"
            Range("B2").Formula = "=MID(B1,40,2)-MID(B1,29,2)"
            Range("C2").Formula = "=IF(AND(B2=0,A2>27,A2<32),0,1)"
            Range("C2").Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                    If Range("C2") = "1" Then
                    MsgBox "Please select no more or less than a month!", vbOKOnly, "Wrong Date Range"
                    Cells.Delete
                     Else
                    End If
            Range("A2:C2").ClearContents
            Columns("B:B").Insert Shift:=xlToRight
            Columns("B:B").Select
            Selection.Insert Shift:=xlToRight
            Range("B4").FormulaR1C1 = "Last Month"
            Range("C4").FormulaR1C1 = "Progression"
            Range("A4").FormulaR1C1 = "Present Month"
            Range("D4").Copy
            Range("A4:C4").Select
            Range("C4").Activate
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
               SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
                    'For Jan we cannot compare the results to previous months
                    If ActiveSheet.Name = "Jan" Then
                    Range("B5").FormulaR1C1 = "N/A"
                    Selection.AutoFill Destination:=Range("B5:B" & LastRaw)
                    Range("C5").FormulaR1C1 = "N/A"
                    Selection.AutoFill Destination:=Range("C5:C" & LastRaw)
                    Range("G:G,K:U").Delete Shift:=xlToLeft
                    Range("1:3").Delete Shift:=xlToUp
                    Else
                    End If
            'Compare client ranking from this month to the previous one
            For K = 2 To LastRaw - 3
                For j = 2 To Sheets(ActiveSheet.Index - 1).Range("A65536").End(xlUp).Row
                    If Range("D" & K) = Sheets(ActiveSheet.Index - 1).Range("D" & j) Then
                    Range("B" & K) = Sheets(ActiveSheet.Index - 1).Range("A" & j)
                    End If
                    Next j
                    Next K
            'Formatting
            Range("G:G,K:U").Delete Shift:=xlToLeft
            Range("1:3").Select
            Selection.Delete Shift:=xlToUp
            For m = 2 To LastRaw - 3
            Range("C" & m) = Range("B" & m) - Range("A" & m)
            Next m
            Range("C2:C" & LastRaw - 3).NumberFormat = "+0_ ;[Red]-0 "
                With Selection.Font
                    .Name = "Arial"
                    .Size = 12
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                    .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                End With
                    'Hilight New client entry
                    For L = 2 To LastRaw - 3
                    If Range("B" & L) = "" Then
                    Range("C" & L).ClearContents
                    Range("C" & L) = "NEW"
                    Range("A" & L & ":I" & L).Interior.Color = RGB(174, 240, 194)
                    End If
                    Next L
                        'Building year Report on the first sheet
                        If ActiveSheet.Name = "Jan" Then
                        Range("D2:I" & LastRaw).Copy
                        Sheets(1).Range("A15").Paste
                        Range("D15:F" & LastRaw).Cut
                        Range("G15").Paste
                        Else
                            For w = 2 To LastRaw - 2
                                For y = 15 To Sheets(1).Range("A65536").End(xlUp).Row
                            If Range("D" & w) = Sheets(1).Range("A" & y) Then
                            Name = (ActiveSheet.Index * 3) + 4
                            Range("G" & LastRaw & ":I" & LastRaw).Copy
                            Sheets(1).Cells(y, Name).Copy
                            Else
                            Range("A" & w & ":C" & w).Copy
                            Sheets(1).Range("A65536").End(xlUp).Paste
                            Name = (ActiveSheet.Index * 3) + 4
                            Range("G" & LastRaw & ":I" & LastRaw).Copy
                            Sheets(1).Cells(y, Name).Copy
                            End If
                            Next y
                            Next w
                            Sheets(1).Rows("14:14").Select
                            Selection.AutoFilter
                            Range("A14:AP1401").Sort Key1:=Range("D14"), Order1:=xlAscending, Header _
                            :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
                            , DataOption1:=xlSortNormal
                             Selection.AutoFilter
                             End If
                        End If
                    MsgBox "Ranking has been processed", VbOnly, "Job Done"
            Else
             MsgBox "No Data has been copied !"
            End If
 
        End If
Else
End If
Next i
Sheets(1).Activate
End Sub

[Philippe Tulliez]

Bonjour,
Manifestement tu n'as absolument pas tenu compte de ma réponse.
Tu as encore des Activate, Selection etc...

[FFGUY]

Bonjour Phillipe,

Lorsque j ai essaye de modifier mon code pour ne plus avoir les select, selection, activate ... Ma macro ne fonctionnait plus correctement, le formatting n etait plus bon et mon classement commence par 0 au lieu de 1.
Quand tu me dis que je peux tout supprimer, peux tu me dire la methode a suivre.

Merci grandement pour ton aide.

[Guiiand]

Bonjour,

Un exemple sur les ligne 16 & 17 de ton code

Code :

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

1
2
Rows("4:4").Select
Selection.AutoFilter

peut s'ecrire directement

Code :

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

Rows("4:4").AutoFilter

Il y a pas mal d’occurrences de ce genre de doublons dans ton code. Tu peux commencer par toutes les modifier.

Cdt

[FFGUY]

Si je transforme le code comme ce qui suit, la Macro me format la premiere page ??

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
Sub TOP_Clients()
 
Application.ScreenUpdating = False
NbSheet = Sheets.Count
 
'Check the sheet is not already formated or not the last one
For i = 2 To NbSheet
    If Sheets(i).Range("A1").Value = "Present Month" Then
    T = i + 1
        If T < NbSheet Then
            If Not IsEmpty(Sheets(T).Range("A1")) Then
                If Not Sheets(T).Range("A1") = "Present Month" Then
                LastRaw = Range("A65536").End(xlUp).Row - 2
                'We sort by executed Volume & start formatting
                Rows("4:4").AutoFilter
                Range("A4:U" & LastRaw).Sort Key1:=Range("G4"), Order1:=xlDescending, Header:= _
                xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                DataOption1:=xlSortNormal
                Rows("4:4").AutoFilter
                 Range("U:U,F:F,E:E").Delete Shift:=xlToLeft
                Columns("A:A").Insert Shift:=xlToRight
                Range("A:A").Font.ColorIndex = 0
                Range("A5").FormulaR1C1 = "1"
                Range("A6").FormulaR1C1 = "2"
                Range("A5:A6").AutoFill Destination:=Range("A5:A" & LastRaw)
                Range("A5").End(xlDown).Font.Bold = True
                    With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
                    End With
                'Check the selection is not more or less than a month
                Range("A2").Formula = "=MID(B1,43,2)- MID(B1,32,2)"
                Range("B2").Formula = "=MID(B1,40,2)-MID(B1,29,2)"
                Range("C2").Formula = "=IF(AND(B2=0,A2>27,A2<32),0,1)"
                Range("C2").Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                        If Range("C2") = "1" Then
                        MsgBox "Please select no more or less than a month!", vbOKOnly, "Wrong Date Range"
                        Cells.Delete
                        End If
                Range("A2:C2").ClearContents
                Columns("B:B").Insert Shift:=xlToRight
                Columns("B:B").Insert Shift:=xlToRight
                Range("B4").FormulaR1C1 = "Last Month"
                Range("C4").FormulaR1C1 = "Progression"
                Range("A4").FormulaR1C1 = "Present Month"
                Range("D4").Copy
                Range("A4:C4").Select
                Range("C4").Activate
                Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
                Application.CutCopyMode = False
                        'For Jan we cannot compare the results to previous months
                        If ActiveSheet.Name = "Jan" Then
                        Range("B5").FormulaR1C1 = "N/A"
                        Selection.AutoFill Destination:=Range("B5:B" & LastRaw)
                        Range("C5").FormulaR1C1 = "N/A"
                        Selection.AutoFill Destination:=Range("C5:C" & LastRaw)
                        Range("G:G,K:U").Delete Shift:=xlToLeft
                        Range("1:3").Delete Shift:=xlToUp
                        End If
                        'Compare client ranking from this month to the previous one
                            For k = 2 To LastRaw - 3
                                For j = 2 To Sheets(ActiveSheet.Index - 1).Range("A65536").End(xlUp).Row
                                    If Range("D" & k) = Sheets(ActiveSheet.Index - 1).Range("D" & j) Then
                                    Range("B" & k) = Sheets(ActiveSheet.Index - 1).Range("A" & j)
                                    End If
                                Next j
                            Next k
                        'Formatting
                        Range("G:G,K:U").Delete Shift:=xlToLeft
                        Range("1:3").Delete Shift:=xlToUp
                            For m = 2 To LastRaw - 3
                            Range("C" & m) = Range("B" & m) - Range("A" & m)
                            Next m
                        Range("C2:C" & LastRaw - 3).NumberFormat = "+0_ ;[Red]-0 "
                        With Selection.Font
                            .Name = "Arial"
                            .Size = 12
                            .Strikethrough = False
                            .Superscript = False
                            .Subscript = False
                            .OutlineFont = False
                            .Shadow = False
                            .Underline = xlUnderlineStyleNone
                            .ColorIndex = xlAutomatic
                        End With
                    'Hilight New client entry
                            For L = 2 To LastRaw - 3
                                If Range("B" & L) = "" Then
                                Range("C" & L).ClearContents
                                Range("C" & L) = "NEW"
                                Range("A" & L & ":I" & L).Interior.Color = RGB(174, 240, 194)
                                End If
                                Next L
                                MsgBox "Ranking has been processed", VbOnly, "Job Done"
                                Else
                                MsgBox "No Data has been copied !"
                                End If
 
                    End If
            End If
End If
Next i
Sheets(1).Activate
End Sub

[Philippe Tulliez]

Bonjour,
Ici par exemple

Code :

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

1
2
Rows("4:4").AutoFilter
                Range("A4:U" & LastRaw).Sort Key1:=Range("G4"), Order1:=xlDescending, Header:= _

Dans ces deux lignes, tu oublies de préciser la feuille
Range de quelle feuille ?
Rows("4:4") de quelle feuille feuille

Bonjour,
Le mieux est de travailler avec une variable objet (ici sht est une variable objet Feuille)

Code :

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

1
2
3
4
5
 Dim sht As Worksheet
 Set sht = ThisWorkbook.Worksheets("Feuil1")
 MsgBox sht.Range("A3")
 Set sht = ThisWorkbook.Worksheets("Feuil2")
 MsgBox sht.Range("A3")

[EDIT]
Un tutoriel à consulter Utiliser les variables en VBA Excel
Exemple : pour mettre en jaune la cellule A1 de toutes les feuilles du classeur où se trouve le code VBA. (Code non testé -écrit de mémoire)

Code :

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

1
2
3
4
 Dim sht As Worksheet
 For Each sht In ThisWorkbook.Worksheets
  sht.Range("A1").Interior.Color = vbYellow
 Next

[FFGUY]

Il faut que je precise les feuilles dans toutes mes lignes ou seulement les deux que tu m as precise ?