Weighted Percentile -- Amendments to an existing UDF

Juggler_IN

Active Member
Joined
Nov 19, 2014
Messages
347
Office Version
  1. 2003 or older
Platform
  1. Windows
I am starting a new thread regarding the UDF at:
weighted percentile

There is a quartile/percentile UDF by Jerry at:
Excel - Interquartile Range Miscalulation

Which is:
VBA Code:
Public Function Quartile( _
       ByVal x As Variant, _
       ByVal q As Variant, _
       ByVal m As Variant) As Double
   
    Dim intM%, lngN&, dblP#, dblH#, dblC#, lngH&, dblG#

    lngN = Application.WorksheetFunction.Count(x)
    intM = m
    dblP = q

    Select Case intM
    Case Is = 4
        dblC = CDbl(0#)
    Case Is = 5
        dblC = CDbl(1# / 2#)
    Case Is = 6
        dblC = CDbl(dblP)
    Case Is = 7
        dblC = CDbl(1# - dblP)
    Case Is = 8
        dblC = CDbl((dblP + 1#) / 3#)
    Case Is = 9
        dblC = CDbl((dblP + (3# / 2#)) / 4#)
    Case Else
        dblC = CDbl(dblP)
    End Select

    dblH = lngN * dblP + dblC
    lngH = Fix(dblH)
    If lngH = 0& Then lngH = 1&
    If lngH > lngN Then lngH = lngN
    dblG = dblH - lngH
    If dblG >= 0# And lngH < lngN Then
        Quartile = (1# - dblG) * Application.WorksheetFunction.Small(x, lngH) + dblG * Application.WorksheetFunction.Small(x, lngH + 1#)
    Else
        Quartile = Application.WorksheetFunction.Small(x, lngH)
    End If

End Function

Can this be integrated with the Wt. Percentile UDF:
Code:
Function WgtPctileIncIf(rTest As Range, vTest As Variant, _
                        rVal As Range, rWgt As Range, _
                        dPct As Double) As Variant
  ' shg 2018
  ' UDF only

  Dim col           As Collection     ' order statistics: {value, wgt, rank of last item}
  Dim i             As Long
  Dim j             As Long
  Dim dVal          As Double
  Dim iWgt          As Long

  If dPct < 0# Or dPct > 1# Then
    WgtPctileIncIf = "Pct = [0,1]!"

  ElseIf rVal.Rows.Count <> rWgt.Rows.Count Or _
         rVal.Columns.Count <> rWgt.Columns.Count Then
    WgtPctileIncIf = "Inputs!"

  Else
    Set col = New Collection

    With col
      .Add Item:=VBA.Array(-1.79E+308, 0&, 0&)  ' dummy for sorting

      For i = 1 To rVal.Cells.Count
        If rTest.Cells(i).Value = vTest Then
          dVal = rVal.Cells(i).Value2
          iWgt = rWgt.Cells(i).Value2

          If iWgt < 0 Then
            WgtPctileIncIf = "Wgt = [0,]!"
            Exit Function

          ElseIf iWgt > 0 Then
            For j = .Count To 1 Step -1
              ' insertion-sort the values

              Select Case Sgn(dVal - .Item(j)(0))
                Case -1  ' less than; increase rank and continue
                  .Add Item:=VBA.Array(.Item(j)(0), .Item(j)(1), .Item(j)(2) + iWgt), After:=j
                  .Remove j

                Case 0  ' same value; combine
                  .Add Item:=VBA.Array(dVal, .Item(j)(1) + iWgt, .Item(j)(2) + iWgt), After:=j
                  .Remove j
                  Exit For

                Case 1  ' greater; add after
                  .Add Item:=VBA.Array(dVal, iWgt, .Item(j)(2) + iWgt), After:=j
                  Exit For
              End Select
            Next j
          End If
        End If
      Next i

      .Remove 1  ' the temp
    End With

    WgtPctileIncIf = dWgtPctileInc(col, dPct)
  End If
End Function

Function dWgtPctileInc(col As Collection, dPct As Double) As Double
  ' shg 2018
  ' VBA only

  ' https://en.wikipedia.org/wiki/Percentile#Second_variant,_%7F'%22%60UNIQ--postMath-00000047-QINU%60%22'%7F
  ' https://en.wikipedia.org/wiki/Percentile#The_weighted_percentile_method

  ' this should be recoded as a binary search

  Dim SN            As Long    ' total  weight
  Dim x             As Double  ' rank of sought value
  Dim xInt          As Long    ' int(x)
  Dim xFrac         As Double  ' mod(x, 10
  Dim j             As Long    ' index to collection

  With col
    SN = .Item(.Count)(2)
    x = dPct * (SN - 1) + 1
    xInt = Int(x)
    xFrac = x - xInt

    For j = 1 To .Count
      If .Item(j)(2) >= x Then
        If x >= .Item(j)(2) - .Item(j)(1) + 1 Then
          ' it's entirely within the level
          dWgtPctileInc = .Item(j)(0)
        Else
          ' it's between levels
          dWgtPctileInc = .Item(j - 1)(0) * (1 - xFrac) + .Item(j)(0) * xFrac
        End If
        Exit For
      End If
    Next j
  End With
End Function

Such that one is able to pick a method for percentile estimation?
 
Last edited by a moderator:
You can amend the loop for the array - something like:

VBA Code:
ReDim x(1 To lngN, 1 to ubound(col(1) + 1)
   Dim n As Long
   For n = 1 To lngN
      dim y as long
      for y = lbound(col(1)) to ubound(col(1))
      x(n, y + 1) = col(n)(y)
      next y
   Next
 
Upvote 0

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top