Thursday, November 7, 2013

CustomPercentile Function using VBA

Option Explicit
Option Base 1
Dim notemptyrng As Boolean
Function customPercentile(myrng As Range, myval As Double) As Variant
Dim Data() As Double
Dim i  As Long, j As Long, nearestRank As Long
    If isRangeEmpty(myrng) = False Then
            customPercentile = "Input Range is Empty"
            Exit Function
    End If
    If (myval < 0 Or myval > 100) Then
        customPercentile = "Percentile must be between 0& 100"
   
    End If
    ReDim Data(myrng.Rows.Count * myrng.Columns.Count)
    For i = 1 To myrng.Rows.Count
        For j = 1 To myrng.Columns.Count
                If IsNumeric(myrng.Cells(i, j)) = True Then
                    Data(i * j) = myrng.Cells(i, j)
                Else
                    customPercentile = "Error exists in" & myrng.Cells(i, j).Address
                    Exit Function
                End If
        Next
    Next
    Call myBubbleSort(Data)
    nearestRank = Round(myval / 100 * (myrng.Rows.Count * myrng.Columns.Count) + 0.5, 0)
   
    Select Case myval
        Case 0: customPercentile = Data(1)
        Case Else: customPercentile = Data(nearestRank)
    End Select
   
End Function

Function isRangeEmpty(myrng1 As Range) As Boolean
        notemptyrng = False
        If Application.WorksheetFunction.CountA(myrng1) > 0 Then
            notemptyrng = True
        End If
        isRangeEmpty = notemptyrng
End Function

Function myBubbleSort(myArray() As Double) As Variant
    Dim i As Long
    Dim j As Long
    Dim tempval As Variant
    For i = LBound(myArray) To UBound(myArray) - 1
        For j = i + 1 To UBound(myArray)
                If myArray(i) > myArray(j) Then
                tempval = myArray(j)
                myArray(j) = myArray(i)
                myArray(i) = tempval
                End If
        Next
    Next
End Function

No comments:

Post a Comment