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 |
Optimisation de code
Répondre avec citation
et si celle-ci est pertinente pensez à voter 
Partager