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 |
Partager