Sulprobil
Search…
sbSWV
Create statistics for weighted values
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
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