Funktionsteil extrahieren

Option Explicit
Sub Start_Format()
Dim i&, n&, nn&
Dim sMonat1$, sMonat2$
Dim Row1&, Row2&, nCounterBereich&
Dim rngDataBereich As Range, ArData, ArBT(), rngBT As Range, ArMA
Dim Farbe1, Farbe2
Dim booFund As Boolean
Dim MaxRow&
Farbe1 = RGB(0, 200, 0) 'Farbe 1
Farbe2 = RGB(125, 155, 255) 'Farbe 2
Call Events_(False)
'Datenbereich
With Tabelle1
MaxRow = ExecuteExcel4Macro("LOOKUP(2,1/('" & .Name & "'!R1C2:R1000C2""""),ROW('" & .Name  _
_
& "'!R1C2:R1000C2))")
On Error Resume Next
.Rows("43:" & MaxRow).Ungroup
On Error GoTo 0: Err.Clear: Err.Number = 0
On Error GoTo ErrorHandler:
Set rngDataBereich = .Range("A1", .Cells(MaxRow, 1))
With .Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
End With
'keine Daten
If rngDataBereich.Rows.Count = 1 Then Exit Sub
'Daten in Array (geht schneller)
ArData = rngDataBereich.Offset(, 1).Value
'Row2 vorbelegen
Row2 = 1
With rngDataBereich
For i = 1 To UBound(ArData)
If IsDate(ArData(i, 1)) And ArData(i, 1) > 0 And ArData(i, 1)  "" Then
For Row2 = Row1 To UBound(ArData)
If Format(ArData(Row2, 1), "mmmm")  sMonat2 Then
Row2 = Row2 - 1
Exit For
ElseIf UBound(ArData) = Row2 Then
Exit For
End If
Next Row2
'Bereich mehr als 2 Zellen?
If Row2 - Row1 > 0 Then
Format_Bereich Range(.Cells(Row1 + 1, 1), .Cells(Row2, 1)), .Cells(Row1, 1). _
Value
nCounterBereich = nCounterBereich + 1
Range(.Cells(Row1, 1), .Cells(Row2, 1)).Interior.Color = IIf(nCounterBereich  _
Mod 2 = 0, Farbe1, Farbe2)
End If
'wieder auf nächsten Monat vorbelegen
i = Row2
End If
Next i
On Error Resume Next
.Parent.Outline.ShowLevels RowLevels:=1
On Error GoTo 0: Err.Number = 0
  Application.Calculation = xlCalculationAutomatic
ArData = rngBT.Columns(1).Offset(, -2).Value2
ReDim Preserve ArBT(1 To rngBT.Rows.Count, 1 To rngBT.Columns.Count)
For n = 1 To UBound(ArData)
If ArData(n, 1) = "BT" Then
For nn = 1 To UBound(ArBT, 2)
If ArMA(1, nn)  "" Then ArBT(n, nn) = 1
Next nn
End If
Next n
rngBT.Value = ArBT
End With
ErrorHandler:
If Err.Number  0 Then
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
Call Events_(True)
End Sub
Sub Format_Bereich(rngRange As Range, strInhalt$)
With rngRange
.ClearContents
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlVertical
.MergeCells = True
.Rows.Group
.Cells(1, 1).Value = strInhalt
End With
End Sub
Sub Events_(booSchalter As Boolean)
With Application
.EnableEvents = booSchalter
.ScreenUpdating = booSchalter
.Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub