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