|
Falls jemand an der Lösung interessiert ist, hier ist der funktionierende Code. Die Formel berechnet den Expected Shortfall eines Datenvektors für ein bestimmtes Konfidenzniveau.
--------------------------------------------------------------------
Option Explicit
Public Function ES(Data As Variant, ConfLev As Double) As Double
'#################Expected Shortfall#################
'# This Function computes the expected shortfall #
'# for an unsorted data vector #
'####################################################
Dim j, n As Long
Dim Ci, Sum As Double
Dim sorted As Variant
If 0 > ConfLev Or ConfLev > 1 Then
MsgBox ("Confidence level must be between 0 and 1")
Exit Function
End If
n = Excel.WorksheetFunction.Count(Data)
Ci = n * (1 - ConfLev)
'Sorting of vector
sorted = SortV(Data, 0, 2)
'Compute expected shortfall
If Ci < 1 Then
Exit Function
End If
Sum = 0
For j = 1 To Ci
Sum = sorted(j, 1) + Sum
Next j
ES = Sum / Ci
End Function
Public Function SortV(ByRef sortrange As Variant, Optional SortBy As Long, Optional Order As Long = 1) As Variant
Dim iSpacing As Long
Dim iOuter As Long
Dim iInner As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iFinished As Long
Dim numcols As Long, Swap As Long, Swaprtn As Long
Dim Firstcol As Long, LastCol As Long
If TypeName(sortrange) = "Range" Then sortrange = sortrange.Value2
iLBound = LBound(sortrange)
iUBound = UBound(sortrange)
Firstcol = LBound(sortrange, 2)
LastCol = UBound(sortrange, 2)
If SortBy = 0 Then SortBy = Firstcol
'Initialise comb width
iSpacing = iUBound - iLBound
Do
If iSpacing > 1 Then
iSpacing = Int(iSpacing / 1.3)
If iSpacing = 0 Then
iSpacing = 1 'Dont go lower than 1
ElseIf iSpacing > 8 And iSpacing < 11 Then
iSpacing = 11 'This is a special number, goes faster than 9 and 10
End If
End If
'Always go down to 1 before attempting to exit
If iSpacing = 1 Then iFinished = 1
'Combing pass
For iOuter = iLBound To iUBound - iSpacing
iInner = iOuter + iSpacing
If Order = 1 Then
If sortrange(iOuter, SortBy) > sortrange(iInner, SortBy) Then Swap = 1
Else
If sortrange(iOuter, SortBy) < sortrange(iInner, SortBy) Then Swap = 1
End If
If Swap = 1 Then
Swaprtn = SwapRows(sortrange, iOuter, iInner, Firstcol, LastCol)
Swap = 0
'Not finished
iFinished = 0
End If
Next iOuter
Loop Until iFinished
SortV = sortrange
End Function
Public Function SwapRows(SwapArray As Variant, Row1 As Long, Row2 As Long, Firstcol As Long, LastCol As Long) As Long
Dim i As Long, Temp As Variant
For i = Firstcol To LastCol
Temp = SwapArray(Row1, i)
SwapArray(Row1, i) = SwapArray(Row2, i)
SwapArray(Row2, i) = Temp
Next i
If i = LastCol Then SwapRows = 0 Else SwapRows = i
End Function
|