パーフェクトなパーセンタイル関数

今日は初めて「プログラミング」のカテゴリーで書いてみます。ExcelにPercentRank関数というのがあり，データ列とスカラー値を与えると，データ列を内部でソートした上でスカラー値が何パーセンタイルにあたるかを返す関数です。演算速度も速くてなかなか便利な関数なんですが，最小値が0パーセンタイル，最大値が100パーセンタイルになってしまうのが不満です。データ列が100個あったら，一番小さい値は0パーセンタイルではなく0.5パーセンタイルであるべきなのに，Excelではそうなっていません。また，同じ数がある場合に最小のパーセンタイルで埋め尽くしてしまうのも不満です。最小のパーセンタイルと最大のパーセンタイルだけ残して，後は捨ててしまうのがパーフェクトなパーセンタイル関数だと考え，以下，代わりの関数を書いてみました。おしまい。

Option Explicit
Option Base 1

'***
'***　縦ベクトルをソートした上で途中の重複する値を（最大二個まで）間引いた上でパーセンタイル作成
'***　NoFlatフラグがTrueの場合は途中のフラットを補間で斜めにつなぎ，両端のフラットを切り落とす
'***
Public Function MakePerfectPercentile(zz As Variant, Optional NoFlat As Boolean = False) As Variant

    Dim zzz As Variant, n As Long, data As Variant
    Dim rra As Double, l As Long, j As Long, ir As Long, i As Long
    zzz = zz
    n = UBound(zzz, 1)
    
    '*** ヒープソート
    l = Int(n / 2) + 1
    ir = n
    Do
        If l > 1 Then
            l = l - 1
            rra = zzz(l, 1)
        Else
            rra = zzz(ir, 1)
            zzz(ir, 1) = zzz(1, 1)
            ir = ir - 1
            If ir = 1 Then
                zzz(1, 1) = rra
                Exit Do
            End If
        End If
        i = l
        j = l * 2
        Do While j <= ir
            If j < ir Then
                If zzz(j, 1) < zzz(j + 1, 1) Then
                j = j + 1
                End If
            End If
            If rra < zzz(j, 1) Then
                zzz(i, 1) = zzz(j, 1)
                i = j
                j = j + i
            Else
                j = ir + 1
            End If
        Loop
        zzz(i, 1) = rra
    Loop
    
    '*** 途中の重複する値を（最大二個まで）間引いた上でパーセンタイル作成
    ReDim data(n, 2) As Double
    Dim dupflag As Boolean
    dupflag = False
    j = 1
    For i = 1 To n
        If j > n Then Exit For
        If Not dupflag Then
            If i > 1 Then
                If zzz(j, 1) = data(i - 1, 1) Then
                    dupflag = True
                End If
            End If
        Else
            Do While zzz(j, 1) = data(i - 1, 1)
                data(i - 1, 2) = (j - 0.5) / n
                j = j + 1
                If j > n Then Exit For
            Loop
            dupflag = False
        End If
        data(i, 1) = zzz(j, 1)
        data(i, 2) = (j - 0.5) / n
        j = j + 1
    Next i
    For i = i To n
        data(i, 1) = data(i - 1, 1)
        data(i, 2) = data(i - 1, 2)
    Next i
    
    If Not NoFlat Then
        MakePerfectPercentile = data
        Exit Function
    End If
    '*** NoFlatフラグがTrueの場合
    Dim datadata As Variant
    datadata = data
    j = 1
    i = 1
    Do
        datadata(j, 1) = data(i, 1)
        datadata(j, 2) = data(i, 2)
        j = j + 1
        If i = n Then
            Exit Do
        End If
        If data(i, 1) = data(i + 1, 1) Then
            If data(i, 2) = data(i + 1, 2) Then
                Exit Do
            End If
            datadata(j - 1, 2) = (data(i, 2) + data(i + 1, 2)) / 2
            i = i + 2
        Else
            i = i + 1
        End If
    Loop
    If data(1, 1) = data(2, 1) Then
        datadata(1, 1) = (data(2, 1) + data(3, 1)) / 2
        datadata(1, 2) = (data(2, 2) + data(3, 2)) / 2
    End If
    If data(i - 1, 1) = data(i, 1) Then
        j = j - 1
        i = i - 1
        datadata(j - 1, 1) = (data(i - 2, 1) + data(i - 1, 1)) / 2
        datadata(j - 1, 2) = (data(i - 2, 2) + data(i - 1, 2)) / 2
    End If
    For j = j To n
        datadata(j, 1) = datadata(j - 1, 1)
        datadata(j, 2) = datadata(j - 1, 2)
    Next j
    
    MakePerfectPercentile = datadata

End Function

'***
'***　線形補間（縦ベクトル）
'***　補外制御あり
'***
Public Function InterpCol(x As Double, xx As Variant, yy As Variant, Optional NoHogai As Boolean = False) As Variant

    On Error GoTo NA
    
    Dim xxx As Variant, yyy As Variant, n As Long, i As Long, Tmp As Double
    xxx = xx
    yyy = yy
    n = UBound(xxx, 1)
    For i = 2 To n
        If x <= xxx(i, 1) Then
            Tmp = WorksheetFunction.Max(0, WorksheetFunction.Min(1, (xxx(i, 1) - x) / (xxx(i, 1) - xxx(i - 1, 1))))
            InterpCol = Tmp * yyy(i - 1, 1) + (1 - Tmp) * yyy(i, 1)
            Exit Function
        End If
    Next i
    Tmp = (xxx(n, 1) - x) / (xxx(n, 1) - xxx(n - 1, 1))
    If NoHogai Then
        If Tmp < 0 Or 1 < Tmp Then
NA:
            InterpCol = CVErr(2042)
            Exit Function
        End If
    End If
    'Tmp = WorksheetFunction.Max(0, WorksheetFunction.Min(1, Tmp))
    InterpCol = Tmp * yyy(n - 1, 1) + (1 - Tmp) * yyy(n, 1)

End Function