|
Need to expand Macro
How do I expand this macro from ABC to A+ A B C D? Public Function ABCRank(Test_Value As Single, Test_Range As Range, Upper_Cutoff As Single, Lower_Cutoff As Single) Application.Volatile Dim A_Rank As Single Dim B_Rank As Single Dim C_Rank As Single A_Rank = Excel.WorksheetFunction.Percentile(Test_Range, Upper_Cutoff) A_Rank = Format(A_Rank, "0.00") C_Rank = Excel.WorksheetFunction.Percentile(Test_Range, Lower_Cutoff) C_Rank = Format(C_Rank, "0.00") Select Case Test_Value Case Is = A_Rank ABCRank = "A" Case Is <= C_Rank ABCRank = "C" Case Else If Test_Value < A_Rank And Test_Value C_Rank Then ABCRank = "B" Else ABCRank = "Error" End If End Select End Function +-------------------------------------------------------------------+ |Filename: ABC-1.zip | |Download: http://www.excelforum.com/attachment.php?postid=4391 | +-------------------------------------------------------------------+ -- nander ------------------------------------------------------------------------ nander's Profile: http://www.excelforum.com/member.php...fo&userid=6156 View this thread: http://www.excelforum.com/showthread...hreadid=515592 |
Need to expand Macro
This is UNTESTED: if the cutoffs are non-volatile, you could hold them as an
array in the function, pass only the test value, and compare this against the array. Public Function ABCRank(Test_Value As Single, Test_Range As Range, _ AA_Cutoff As Single, A_Cutoff As Single, B_Cutoff As Single, C_Cutoff As Single) Application.Volatile Dim AA_Rank As Single Dim A_Rank As Single Dim B_Rank As Single Dim C_Rank As Single AA_Rank = Excel.WorksheetFunction.Percentile(Test_Range, AA_Cutoff) AA_Rank = Format(AA_Rank, "0.00") A_Rank = Excel.WorksheetFunction.Percentile(Test_Range, A_Cutoff) A_Rank = Format(A_Rank, "0.00") B_Rank = Excel.WorksheetFunction.Percentile(Test_Range, B_Cutoff) B_Rank = Format(B_Rank, "0.00") C_Rank = Excel.WorksheetFunction.Percentile(Test_Range, C_Cutoff) C_Rank = Format(C_Rank, "0.00") Select Case Test_Value Case Is = AA_Rank ABCRank = "A+" Case Is = A_Rank ABCRank = "A" Case Is = B_Rank ABCRank = "B" Case Is <= D_Rank ABCRank = "D" Case Else If Test_Value < B_Rank And Test_Value D_Rank Then ABCRank = "C" Else ABCRank = "Error" End If End Select "nander" wrote: How do I expand this macro from ABC to A+ A B C D? Public Function ABCRank(Test_Value As Single, Test_Range As Range, Upper_Cutoff As Single, Lower_Cutoff As Single) Application.Volatile Dim A_Rank As Single Dim B_Rank As Single Dim C_Rank As Single A_Rank = Excel.WorksheetFunction.Percentile(Test_Range, Upper_Cutoff) A_Rank = Format(A_Rank, "0.00") C_Rank = Excel.WorksheetFunction.Percentile(Test_Range, Lower_Cutoff) C_Rank = Format(C_Rank, "0.00") Select Case Test_Value Case Is = A_Rank ABCRank = "A" Case Is <= C_Rank ABCRank = "C" Case Else If Test_Value < A_Rank And Test_Value C_Rank Then ABCRank = "B" Else ABCRank = "Error" End If End Select End Function +-------------------------------------------------------------------+ |Filename: ABC-1.zip | |Download: http://www.excelforum.com/attachment.php?postid=4391 | +-------------------------------------------------------------------+ -- nander ------------------------------------------------------------------------ nander's Profile: http://www.excelforum.com/member.php...fo&userid=6156 View this thread: http://www.excelforum.com/showthread...hreadid=515592 |
Need to expand Macro
Sorry - mistake in previous version (this is still untested):
Public Function ABCRank(Test_Value As Single, Test_Range As Range, _ AA_Cutoff As Single, A_Cutoff As Single, B_Cutoff As Single, D_Cutoff As Single) Application.Volatile Dim AA_Rank As Single Dim A_Rank As Single Dim B_Rank As Single Dim D_Rank As Single AA_Rank = Excel.WorksheetFunction.Percentile(Test_Range, AA_Cutoff) AA_Rank = Format(AA_Rank, "0.00") A_Rank = Excel.WorksheetFunction.Percentile(Test_Range, A_Cutoff) A_Rank = Format(A_Rank, "0.00") B_Rank = Excel.WorksheetFunction.Percentile(Test_Range, B_Cutoff) B_Rank = Format(B_Rank, "0.00") D_Rank = Excel.WorksheetFunction.Percentile(Test_Range, D_Cutoff) D_Rank = Format(D_Rank, "0.00") Select Case Test_Value Case Is = AA_Rank ABCRank = "A+" Case Is = A_Rank ABCRank = "A" Case Is = B_Rank ABCRank = "B" Case Is <= D_Rank ABCRank = "D" Case Else If Test_Value < B_Rank And Test_Value D_Rank Then ABCRank = "C" Else ABCRank = "Error" End If End Select End Function "Toppers" wrote: This is UNTESTED: if the cutoffs are non-volatile, you could hold them as an array in the function, pass only the test value, and compare this against the array. Public Function ABCRank(Test_Value As Single, Test_Range As Range, _ AA_Cutoff As Single, A_Cutoff As Single, B_Cutoff As Single, C_Cutoff As Single) Application.Volatile Dim AA_Rank As Single Dim A_Rank As Single Dim B_Rank As Single Dim C_Rank As Single AA_Rank = Excel.WorksheetFunction.Percentile(Test_Range, AA_Cutoff) AA_Rank = Format(AA_Rank, "0.00") A_Rank = Excel.WorksheetFunction.Percentile(Test_Range, A_Cutoff) A_Rank = Format(A_Rank, "0.00") B_Rank = Excel.WorksheetFunction.Percentile(Test_Range, B_Cutoff) B_Rank = Format(B_Rank, "0.00") C_Rank = Excel.WorksheetFunction.Percentile(Test_Range, C_Cutoff) C_Rank = Format(C_Rank, "0.00") Select Case Test_Value Case Is = AA_Rank ABCRank = "A+" Case Is = A_Rank ABCRank = "A" Case Is = B_Rank ABCRank = "B" Case Is <= D_Rank ABCRank = "D" Case Else If Test_Value < B_Rank And Test_Value D_Rank Then ABCRank = "C" Else ABCRank = "Error" End If End Select "nander" wrote: How do I expand this macro from ABC to A+ A B C D? Public Function ABCRank(Test_Value As Single, Test_Range As Range, Upper_Cutoff As Single, Lower_Cutoff As Single) Application.Volatile Dim A_Rank As Single Dim B_Rank As Single Dim C_Rank As Single A_Rank = Excel.WorksheetFunction.Percentile(Test_Range, Upper_Cutoff) A_Rank = Format(A_Rank, "0.00") C_Rank = Excel.WorksheetFunction.Percentile(Test_Range, Lower_Cutoff) C_Rank = Format(C_Rank, "0.00") Select Case Test_Value Case Is = A_Rank ABCRank = "A" Case Is <= C_Rank ABCRank = "C" Case Else If Test_Value < A_Rank And Test_Value C_Rank Then ABCRank = "B" Else ABCRank = "Error" End If End Select End Function +-------------------------------------------------------------------+ |Filename: ABC-1.zip | |Download: http://www.excelforum.com/attachment.php?postid=4391 | +-------------------------------------------------------------------+ -- nander ------------------------------------------------------------------------ nander's Profile: http://www.excelforum.com/member.php...fo&userid=6156 View this thread: http://www.excelforum.com/showthread...hreadid=515592 |
| All times are GMT +1. The time now is 09:12 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com