Juggler_IN
Active Member
- Joined
- Nov 19, 2014
- Messages
- 349
- Office Version
- 2003 or older
- Platform
- 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:
Can this be integrated with the Wt. Percentile UDF:
Such that one is able to pick a method for percentile estimation?
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: