Sulprobil
Search…
sbSWV
Create statistics for weighted values
Please read my Disclaimer.
1
#Const SORTED = False
2
3
Function sbSWV(sStat As String, _
4
ParamArray vInput() As Variant) As Variant
5
'Calulates some statistical measures of weighted values
6
'Reverse("moc.LiborPlus.www") V0.8 29-Jun-2020
7
Dim d As Double, d2 As Double, dSum As Double
8
Dim i As Long, j As Long, k As Long, m As Long, n As Long
9
Dim vV, vV2, vV3, vW 'Variants
10
11
With Application.WorksheetFunction
12
vV = .Transpose(vInput(0))
13
Select Case sStat
14
Case "COVAR", "CORREL"
15
vV2 = .Transpose(vInput(1))
16
vW = .Transpose(vInput(2))
17
Case Else
18
vW = .Transpose(vInput(1))
19
End Select
20
On Error GoTo errhdl
21
i = vV(1) 'Force error in case of vertical arrays
22
On Error GoTo 0
23
If UBound(vV) <> UBound(vW) Then
24
'Arrays of values and of weights must have same dimension
25
sbSWV = CVErr(xlErrNum)
26
Exit Function
27
End If
28
Select Case UCase(sStat)
29
Case "AVERAGE"
30
sbSWV = .SumProduct(vV, vW) / .Sum(vW)
31
Case "CORREL"
32
vV3 = vV
33
dSum = .Sum(vW)
34
d = .SumProduct(vV, vW) / dSum
35
d2 = .SumProduct(vV2, vW) / dSum
36
For i = LBound(vV) To UBound(vV)
37
vV3(i) = vW(i) * (vV(i) - d) * (vV2(i) - d2)
38
vV(i) = vW(i) * (vV(i) - d) ^ 2#
39
vV2(i) = vW(i) * (vV2(i) - d2) ^ 2#
40
Next i
41
sbSWV = .Sum(vV3) / Sqr(.Sum(vV) * .Sum(vV2))
42
Case "COVAR"
43
dSum = .Sum(vW)
44
d = .SumProduct(vV, vW) / dSum
45
d2 = .SumProduct(vV2, vW) / dSum
46
For i = LBound(vV) To UBound(vV)
47
vV(i) = vW(i) * (vV(i) - d) * (vV2(i) - d2)
48
Next i
49
sbSWV = .Sum(vV) / dSum
50
Case "MODE"
51
k = .Max(vW)
52
If k < 2 Then
53
sbSWV = CVErr(xlErrNA)
54
Exit Function
55
End If
56
sbSWV = vV(.Match(.Max(vW), vW, False))
57
Case "MEDIAN"
58
If .Min(vW) < 1 Then
59
sbSWV = CVErr(xlErrNA)
60
Exit Function
61
End If
62
k = 0
63
j = .Sum(vW)
64
m = j Mod 2
65
For i = LBound(vW) To UBound(vW)
66
If vW(i) Mod 1 <> 0 Then
67
sbSWV = CVErr(xlErrNum)
68
Exit Function
69
End If
70
#If Not SORTED Then
71
'Ensure ascending values in case input is unsorted.
72
'This simple bubble sort leads to a quadratic runtime
73
'but it's still quicker on 50 input values or more than
74
'Lorimer Miller's nifty worksheet function approach
75
'=LOOKUP(2,1/FREQUENCY(SUM(B1:B50)/2,SUMIF(A1:A50,"<="&A1:A50,B1:B50)),A1:A50)
76
'BTW: Lorimer's approach is different from Excel's MEDIAN
77
'(see below); and his other elegant array formula
78
'=MEDIAN(IF(TRANSPOSE(ROW(A1:A1000))<=B1:B50,A1:A50))
79
'calculates like Excel's MEDIAN but IMHO it's way too slow
80
For n = i + 1 To UBound(vW)
81
If vV(n) < vV(i) Then
82
d = vV(i)
83
vV(i) = vV(n)
84
vV(n) = d
85
d = vW(i)
86
vW(i) = vW(n)
87
vW(n) = d
88
End If
89
Next n
90
#End If
91
k = k + vW(i)
92
Select Case 2 * k
93
Case j + m
94
If m = 0 Then
95
#If Not SORTED Then
96
'Ensure vV(i + 1) is next greater value
97
For n = i + 2 To UBound(vW)
98
If vV(n) < vV(i + 1) Then
99
vV(i + 1) = vV(n)
100
End If
101
Next n
102
#End If
103
'Here Lorimer's function mentioned above would
104
'return vV(i), the lower value
105
sbSWV = (vV(i) + vV(i + 1)) / 2#
106
Else
107
sbSWV = vV(i)
108
End If
109
Exit Function
110
Case Is > j + m
111
sbSWV = vV(i)
112
Exit Function
113
End Select
114
Next i
115
Case "STDEV"
116
dSum = .Sum(vW)
117
d = .SumProduct(vV, vW) / dSum
118
For i = LBound(vV) To UBound(vV)
119
vV(i) = Abs(vV(i) - d) ^ 2#
120
Next i
121
sbSWV = Sqr(.SumProduct(vV, vW) / (dSum - 1#))
122
Case "VAR"
123
dSum = .Sum(vW)
124
d = .SumProduct(vV, vW) / dSum
125
For i = LBound(vV) To UBound(vV)
126
vV(i) = vW(i) * (vV(i) - d) ^ 2#
127
Next i
128
sbSWV = .Sum(vV) / (dSum - 1#)
129
Case Else
130
sbSWV = CVErr(xlErrValue)
131
End Select
132
Exit Function
133
errhdl:
134
'Transpose variants to be able to address them
135
'with vV(i), not vV(i,1)
136
vV = .Transpose(vV)
137
vW = .Transpose(vW)
138
Select Case sStat
139
Case "COVAR", "CORREL"
140
vV2 = .Transpose(vV2)
141
End Select
142
Resume Next
143
End With
144
End Function
Copied!
sbSWV.xlsm
59KB
Binary
sbSWV.xlsm
Last modified 1yr ago
Copy link