Trennung von Quartalen

Private Sub But_dieser_Jahr_Quartal_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim dtDatum As Date
Dim dtMonat As Integer
Dim dtJahr As Integer
dtJahr = 2004
dtMonat = 10
Dim Ws As Worksheet, Ws1 As Worksheet
Dim Mt(), i&
On Error Resume Next
Mt = Array("1.Quartal", "2. Quartal", "3.Quartal", "4. Quartal")
' Sheets herstellen
For i = 0 To UBound(Mt)
Set Ws = Worksheets(Mt(i))
If Err.Number <> 0 Then _
Set Ws = Sheets.Add(After:=Worksheets(Worksheets.Count)): Ws.Name = Mt(i)
Err.Clear
Next i
Set Ws = Worksheets(TBL)
If Err.Number <> 0 Then _
MsgBox "Blatt " & TBL & " nicht gefunden .. ", vbCritical: Exit Sub
' Einsortieren
With Ws
For i = 1 To .Cells(Rows.Count, Range(STARTZELLE).Column).End(xlUp).Row
' handelt es sich überhaupt um ein Datum ?
If IsDate(.Cells(i, Range(STARTZELLE).Column).Value) Then
'kopieren der Daten auf das entsprechende Monatsblatt
' ( Zeile ins Monatsblatt )
'Und jetzt kommt die Jahresabfrage
If Month(dtDatum) <> dtMonat And Month(dtDatum) <> dtMonat + 1 And Month(dtDatum) <> dtMonat + 2 And Format(Year(dtDatum), "yyyy") <> dtJahr Then
Set Ws1 = Worksheets(Mt(Month(.Cells(i, Range(STARTZELLE).Column).Value) - 1))
' kopieren der Zeile in das entsprechende Blatt in die erste freie Zeile
.Range(.Cells(i, 1), .Cells(i, LAST_COL)).Copy Destination:= _
Ws1.Cells(Ws1.Cells(Rows.Count, Range(STARTZELLE).Column).End(xlUp).Row + 1, 1)
' loeschen der Zeile
.Range(.Cells(i, 1), .Cells(i, LAST_COL)).ClearContents
End If
End If
Next i
End With
Set Ws = Nothing: Erase Mt: Set Ws1 = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub