AW: Kompl. Formel STABW(N) in VBA-Code packen ....
14.09.2007 11:07:00
ingUR
Hallo, Ralph,
da besteht auch noch ide etwas elegantere Möglichkeit, der Prozedur als ersten Parameter eine Feld für die vier Ergebniswerte zu übergeben, in dass die Funktionsresultate hineingeschrieben werden und die dann in den aufrufenden Prozeduren in die entsprechenden Zellen geschrieben werden. Dadurch entfällt die wiederholte Berechnung der Tabellenwerte für den "Standard"-VolaPeriodenwert am Ende einer Schleife über verschiedene VolaPeriodwerte.
Hier der gesamte veränderte Programmcode aus Deiner Beispielmappe:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range, dblResult(4) As Double, i As Integer
Set Bereich = ActiveWorkbook.Worksheets("LCDXInput").Range("K:K")
If Not Intersect(Target, Bereich) Is Nothing Then
CalcLCDX dblResult
For i = 0 To 3
Cells(Target.Row, "L").Offset(0, i) = dblResult(i)
Next i
End If
End Sub
Sub CalcLCDX(dblResult() As Double, Optional LastR As Long = -1)
Dim rngData As Range, StartRow As Long
If LastR 0 Then
StartRow = LastR - Application.Min(CInt(Mid(ActiveWorkbook.Names("VolaPeriod"), 2)), _
LastR - 3)
Set rngData = Range(Cells(StartRow, "K"), Cells(LastR, "K"))
dblResult(0) = Application.WorksheetFunction.StDevP(rngData)
dblResult(1) = Application.WorksheetFunction.StDev(rngData)
dblResult(2) = Cells(LastR, "M") * Sqr(252)
Set rngData = Range(Cells(StartRow + 1, "M"), Cells(LastR, "M"))
dblResult(3) = Application.WorksheetFunction.Average(rngData)
End If
Set rngData = Nothing
End Sub
Private Sub LCDXVola_Click()
Dim objSh As Worksheet
Dim rng As Range, r As Range
Dim dblMax As Double, dblMin As Double
Dim varVola() As Variant
Dim intc As Integer
Dim dblResult(4) As Double, i As Integer
varVola = Array(10, 20, 30, 45, 90, 100)
Set objSh = Sheets("LCDXInput")
With objSh
Set rng = .Range("H2:H" & Application.Max(.Cells(Rows.Count, 1).End(xlUp).Row, 2))
rng.Select
dblMax = Application.Max(rng)
dblMax = dblMax - Weekday(dblMax, vbSunday)
dblMin = Application.Min(rng)
Do While dblMax > dblMin
Set r = rng.Find(what:=CDate(dblMax), LookIn:=xlFormulas, lookat:=xlWhole)
If Not r Is Nothing Then
For intc = 0 To 5
ThisWorkbook.Names("VolaPeriod").Value = varVola(intc)
'.Calculate
CalcLCDX dblResult, r.Row
.Cells(80 + intc, 19) = varVola(intc)
.Cells(80 + intc, 20) = r
For i = 0 To 3
.Cells(80, 21).Offset(intc, i) = dblResult(i)
Next i
Next
Exit Do
End If
dblMax = dblMax - 1
Loop
End With
ThisWorkbook.Names("VolaPeriod").Value = 90
Set r = Nothing
Set rng = Nothing
Set objSh = Nothing
End Sub
Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Modus Then
.Calculation = lngCalc
Else
lngCalc = .Calculation
End If
.Cursor = IIf(Modus, -4143, 2)
.CutCopyMode = False
End With
End Sub
Gruß,
Uwe