Option Explicit
Sub BetterGeomittel()
Const m_ModName As String = "Modul1"
Const m_PrcName As String = "BetterGeomittel"
Const sErsteZelle As String = "A2"
Const lBereich As Long = 12
Const lRechts As Long = 2
Dim rngZinsen As Range
Dim lngOffset As Long
On Error GoTo Geomittel_Error
lngOffset = lBereich - 1
Set rngZinsen = Range(Range(sErsteZelle), _
Range(sErsteZelle).Offset(lngOffset))
Do
If WorksheetFunction.CountBlank(rngZinsen) > 0 Then Exit Do
rngZinsen.Cells(lBereich).Offset(0, lRechts).FormulaR1C1 = fncAccuracy(rngZinsen, 1)
Set rngZinsen = rngZinsen.Offset(lBereich)
Loop
On Error GoTo 0
Geomittel_Error:
Select Case Err.Number
Case Is = 0:
Case Else:
Select Case Errormessage(Application.VBE.ActiveCodePane.CodeModule & _
" < Module / Procedure > " & m_ModName & " / " & m_PrcName)
Case Is = vbAbort:
Application.SendKeys Keys:="{F8}" & "{F8}", Wait:=False
Stop: Resume
Case Is = vbRetry:
Resume
Case Is = vbIgnore:
End Select
End Select
End Sub
Function fncAccuracy(calcR As Range, dFact As Double) As Double
Dim dblProduct As Double
Dim c As Range
dblProduct = 1
For Each c In calcR.Cells
dblProduct = dblProduct * (dFact + c.Value)
Next c
fncAccuracy = -dFact + dblProduct ^ (dFact / calcR.Count)
End Function
Private Function Errormessage(myMacro As String) As Long
Const DebugMode = True
Errormessage = MsgBox("Error#" & Err.Number & vbCrLf & Err.Description, _
IIf(DebugMode, vbAbortRetryIgnore, vbCritical) + vbMsgBoxHelpButton, _
myMacro, Err.HelpFile, Err.HelpContext)
End Function