Saturday, 5 July 2014

Macro to Sort one Specific Column in Ascending and another Specific Column in Descending then give Rank in another Specific Column

Macro to Sort one Specific Column in Ascending and another Specific Column in Descending then give Rank in another Specific Column
Model - I :
Sub Sort_Ascend_Descend_Rank()
Dim RC As Long
Dim CC As Long
Dim Sort_Range As String

'To Get Column Index Number in Used Range(Eg: 1,2,3)
RC = ActiveSheet.UsedRange.Rows.Count
CC = ActiveSheet.UsedRange.Columns.Count 

' To Get Column Index Name in Used Range(Eg: A,B,C..)
CN = Split(Cells(, CC).Address, "$")(1) 


Sort_Range = "$A$1" & " : " & "$" & CN & "$" & RC

For X = 1 To CC
If ActiveSheet.Cells(1, X) = "Product Id" Then
S_1 = Cells(1, X).Column '? Sorting Column-1 Number(Eg: 1,2,3)
SC_1 = Split(Cells(, S_1).Address, "$")(1) '? Sorting Column-1 Index Name(Eg: A,B,C..)

ElseIf ActiveSheet.Cells(1, X) = "Sample" Then
S_2 = Cells(1, X).Column '? Sorting Column-2 Index Number(Eg: 1,2,3)
SC_2 = Split(Cells(, S_2).Address, "$")(1) '? Sorting Column-2 Index Name(Eg: A,B,C..)

ElseIf ActiveSheet.Cells(1, X) = "Rank" Then
RNK_C = Cells(1, X).Column '? Ranking Column Index Number(Eg: 1,2,3)
RNK_CN = Split(Cells(, S_2).Address, "$")(1) '? Ranking Column Index Name(Eg: A,B,C..)

End If
Next X

SC1_Range = "$" & SC_1 & "$1" & " : " & "$" & SC_1 & "$" & RC
SC2_Range = "$" & SC_2 & "$1" & " : " & "$" & SC_2 & "$" & RC

ActiveSheet.Range(Sort_Range).Select

ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range(SC1_Range), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveSheet.Sort.SortFields.Add Key:=Range(SC2_Range), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ActiveSheet.Sort
        .SetRange Range(Sort_Range)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

X = 0
Y = 0
Z = 0
K = 0

For X = 2 To RC 'Total Rows in Used Range

For Y = X To RC

If Cells(Y, S_1) <> Cells(X, S_1) Then Exit For

If (Cells(Y - 1, S_2) <> Cells(Y, S_2)) Then
Z = (Z + 1)
Cells(Y, RNK_C) = Z
K = K + 1

ElseIf (Cells(Y - 1, S_1) = Cells(Y, S_1)) And (Cells(Y - 1, S_2) = Cells(Y, S_2)) Then
Cells(Y, RNK_C) = Z
K = K + 1

Else
Z = Z + 1
Cells(Y, RNK_C) = Z
K = K + 1

End If
Next Y

X = (X + K) - 1
Z = 0
K = 0
Next X

ActiveSheet.Range("$A$1").Select
MsgBox "Job Over", vbOKOnly, "Done"

End Sub
----------------------------------------------------------------------------------------
Model - II :

Sub Sort_Ascend_Descend_Rank()

Dim RC As Long
Dim CC As Long
Dim Sort_Range As String

On Error Resume Next

RC = ActiveSheet.UsedRange.Rows.Count
CC = ActiveSheet.UsedRange.Columns.Count 'To Get Column Index Number in Used Range
CN = Split(Cells(, CC).Address, "$")(1) ' To Get Column Index Name in Used Range

Sort_Range = "$A$1" & " : " & "$" & CN & "$" & RC

'Loop to Convert Each Column As a Named Range with Heading Name

For X = 1 To CC 
If ActiveSheet.Cells(1, X) <> "" Then ActiveSheet.Cells(1, X).EntireColumn.Select
Selection.Name = Cells(1, X).Value
Next X

S_1 = ActiveSheet.Range("Gs_Id").Column ' ? Sorting Column-2 Number ?
S_2 = ActiveSheet.Range("Payout_Weight").Column ' ? Sorting Column-2 Number ?
RNK_C = ActiveSheet.Range("Rank").Column 'Ranking Column Number

ActiveSheet.Range(Sort_Range).Select

ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("Gs_Id"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveSheet.Sort.SortFields.Add Key:=Range("Payout_Weight"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ActiveSheet.Sort
        .SetRange Range(Sort_Range)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

X = 0
Y = 0
Z = 0
K = 0

For X = 2 To RC 'Total Rows in Used Range

For Y = X To RC
If Cells(Y, S_1) <> Cells(X, S_1) Then Exit For

If (Cells(Y - 1, S_2) <> Cells(Y, S_2)) Then
Z = (Z + 1)
Cells(Y, RNK_C) = Z
K = K + 1

ElseIf (Cells(Y - 1, S_1) = Cells(Y, S_1)) And (Cells(Y - 1, S_2) = Cells(Y, S_2)) Then
Cells(Y, RNK_C) = Z
K = K + 1

Else
Z = Z + 1
Cells(Y, RNK_C) = Z
K = K + 1

End If
Next Y

X = (X + K) - 1
Z = 0
K = 0
Next X

ActiveSheet.Range("$A$1").Select
MsgBox "Job Over", vbOKOnly, "Done"

End Sub

No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts