Option Explicit

Sub Geomittel()
'---------------------------------------------------------------------------------------
' Project   : VBAProject
' Module    : Modul
' Procedure : Sub
' Author    : Hmm
' Date      : 02.06.2014
' Time      : 18:54
' Purpose   : VBA-Forum
'---------------------------------------------------------------------------------------
'
Const m_ModName As String = "Stefanie"
Const m_PrcName As String = "Geomittel"
'
Const sErsteZelle As String = "A2"              'Zelle mit "erstem" Zins
Const lBereich As Long = 3                      'jeweils zusammengefasst
Const lRechts As Long = 1                       'Ergbnis um lRechts versetzt
'
Dim rngZinsen As Range                          'Spaltenbereich Zinsen
Dim lngOffset As Long                           'ditto

  On Error GoTo Geomittel_Error

  lngOffset = lBereich - 1                      'immer dazunehmen
  
  Set rngZinsen = Range(Range(sErsteZelle), _
      Range(sErsteZelle).Offset(lngOffset))     '1. Block Größe lBereich
  
  Do
  
    'Abbruch
    If WorksheetFunction.CountBlank(rngZinsen) > 0 Then Exit Do
    
    'Aktion
    rngZinsen.Cells(lBereich).Offset(0, lRechts).FormulaR1C1 = "=GEOMEAN(R[-2]C[-1]:RC[-1])"
    
    'erhöhen
    Set rngZinsen = rngZinsen.Offset(lBereich)
    
  Loop

  On Error GoTo 0
'
'*************************************************************************
Geomittel_Error:
'
Select Case Err.Number
  Case Is = 0: 'errorless
  ' Case is = #: 'custom
  Case Else: 'display
    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: 'User canceled
    End Select
  End Select
'
'*************************************************************************
'
End Sub
'
'*************************************************************************
Private Function Errormessage(myMacro As String) As Long
' vbAbort: Stop: Resume
' vbRetry: Resume
' vbIgnore: User canceled
Const DebugMode = True 'False 'True = debugging
  Errormessage = MsgBox("Error#" & Err.Number & vbCrLf & Err.Description, _
  IIf(DebugMode, vbAbortRetryIgnore, vbCritical) + vbMsgBoxHelpButton, _
myMacro, Err.HelpFile, Err.HelpContext)
End Function
'
'*************************************************************************