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
--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------
No comments:
Post a Comment
Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.