sbSWV

Create statistics for weighted values

Please read my Disclaimer.

#Const SORTED = False
Function sbSWV(sStat As String, _
ParamArray vInput() As Variant) As Variant
'Calulates some statistical measures of weighted values
'Reverse("moc.LiborPlus.www") V0.8 29-Jun-2020
Dim d As Double, d2 As Double, dSum As Double
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim vV, vV2, vV3, vW 'Variants
With Application.WorksheetFunction
vV = .Transpose(vInput(0))
Select Case sStat
Case "COVAR", "CORREL"
vV2 = .Transpose(vInput(1))
vW = .Transpose(vInput(2))
Case Else
vW = .Transpose(vInput(1))
End Select
On Error GoTo errhdl
i = vV(1) 'Force error in case of vertical arrays
On Error GoTo 0
If UBound(vV) <> UBound(vW) Then
'Arrays of values and of weights must have same dimension
sbSWV = CVErr(xlErrNum)
Exit Function
End If
Select Case UCase(sStat)
Case "AVERAGE"
sbSWV = .SumProduct(vV, vW) / .Sum(vW)
Case "CORREL"
vV3 = vV
dSum = .Sum(vW)
d = .SumProduct(vV, vW) / dSum
d2 = .SumProduct(vV2, vW) / dSum
For i = LBound(vV) To UBound(vV)
vV3(i) = vW(i) * (vV(i) - d) * (vV2(i) - d2)
vV(i) = vW(i) * (vV(i) - d) ^ 2#
vV2(i) = vW(i) * (vV2(i) - d2) ^ 2#
Next i
sbSWV = .Sum(vV3) / Sqr(.Sum(vV) * .Sum(vV2))
Case "COVAR"
dSum = .Sum(vW)
d = .SumProduct(vV, vW) / dSum
d2 = .SumProduct(vV2, vW) / dSum
For i = LBound(vV) To UBound(vV)
vV(i) = vW(i) * (vV(i) - d) * (vV2(i) - d2)
Next i
sbSWV = .Sum(vV) / dSum
Case "MODE"
k = .Max(vW)
If k < 2 Then
sbSWV = CVErr(xlErrNA)
Exit Function
End If
sbSWV = vV(.Match(.Max(vW), vW, False))
Case "MEDIAN"
If .Min(vW) < 1 Then
sbSWV = CVErr(xlErrNA)
Exit Function
End If
k = 0
j = .Sum(vW)
m = j Mod 2
For i = LBound(vW) To UBound(vW)
If vW(i) Mod 1 <> 0 Then
sbSWV = CVErr(xlErrNum)
Exit Function
End If
#If Not SORTED Then
'Ensure ascending values in case input is unsorted.
'This simple bubble sort leads to a quadratic runtime
'but it's still quicker on 50 input values or more than
'Lorimer Miller's nifty worksheet function approach
'=LOOKUP(2,1/FREQUENCY(SUM(B1:B50)/2,SUMIF(A1:A50,"<="&A1:A50,B1:B50)),A1:A50)
'BTW: Lorimer's approach is different from Excel's MEDIAN
'(see below); and his other elegant array formula
'=MEDIAN(IF(TRANSPOSE(ROW(A1:A1000))<=B1:B50,A1:A50))
'calculates like Excel's MEDIAN but IMHO it's way too slow
For n = i + 1 To UBound(vW)
If vV(n) < vV(i) Then
d = vV(i)
vV(i) = vV(n)
vV(n) = d
d = vW(i)
vW(i) = vW(n)
vW(n) = d
End If
Next n
#End If
k = k + vW(i)
Select Case 2 * k
Case j + m
If m = 0 Then
#If Not SORTED Then
'Ensure vV(i + 1) is next greater value
For n = i + 2 To UBound(vW)
If vV(n) < vV(i + 1) Then
vV(i + 1) = vV(n)
End If
Next n
#End If
'Here Lorimer's function mentioned above would
'return vV(i), the lower value
sbSWV = (vV(i) + vV(i + 1)) / 2#
Else
sbSWV = vV(i)
End If
Exit Function
Case Is > j + m
sbSWV = vV(i)
Exit Function
End Select
Next i
Case "STDEV"
dSum = .Sum(vW)
d = .SumProduct(vV, vW) / dSum
For i = LBound(vV) To UBound(vV)
vV(i) = Abs(vV(i) - d) ^ 2#
Next i
sbSWV = Sqr(.SumProduct(vV, vW) / (dSum - 1#))
Case "VAR"
dSum = .Sum(vW)
d = .SumProduct(vV, vW) / dSum
For i = LBound(vV) To UBound(vV)
vV(i) = vW(i) * (vV(i) - d) ^ 2#
Next i
sbSWV = .Sum(vV) / (dSum - 1#)
Case Else
sbSWV = CVErr(xlErrValue)
End Select
Exit Function
errhdl:
'Transpose variants to be able to address them
'with vV(i), not vV(i,1)
vV = .Transpose(vV)
vW = .Transpose(vW)
Select Case sStat
Case "COVAR", "CORREL"
vV2 = .Transpose(vV2)
End Select
Resume Next
End With
End Function