Копирование макросом данных в отдельный лист по условию

Sub MMM()
T1 = Timer
LR = Cells(Rows.Count, 4).End(xlUp).Row
R = Range("A1:F1").Value
ARR0 = Range(Cells(2, 1), Cells(LR, 6)).Value
ReDim ARR1(1 To UBound(ARR0), 1 To UBound(ARR0, 2))
ReDim ARR2(1 To UBound(ARR0), 1 To UBound(ARR0, 2))
ReDim ARR3(1 To UBound(ARR0), 1 To UBound(ARR0, 2))
ReDim ARR4(1 To UBound(ARR0), 1 To UBound(ARR0, 2))
 
M1 = 1: M2 = 1: M3 = 1: M4 = 1
For i = 1 To UBound(ARR0)
 MNTH = Month(CDate(ARR0(i, 4)))
 Select Case MNTH
    Case 1 To 3
        For j = 1 To UBound(ARR0, 2)
            ARR1(M1, j) = ARR0(i, j)
        Next
        M1 = M1 + 1
    Case 4 To 6
        For j = 1 To UBound(ARR0, 2)
            ARR2(M2, j) = ARR0(i, j)
        Next
        M2 = M2 + 1
    Case 7 To 9
        For j = 1 To UBound(ARR0, 2)
            ARR3(M3, j) = ARR0(i, j)
        Next
        M3 = M3 + 1
    Case 10 To 12
        For j = 1 To UBound(ARR0, 2)
            ARR4(M4, j) = ARR0(i, j)
        Next
        M4 = M4 + 1
 End Select
 
Next
Application.ScreenUpdating = False
With Sheets("кв1")
.Range("A1:F1").Value = R
.Cells(2, 1).Resize(UBound(ARR0), UBound(ARR0, 2)).Value = ARR1
End With
With Sheets("кв2")
.Range("A1:F1").Value = R
.Cells(2, 1).Resize(UBound(ARR0), UBound(ARR0, 2)).Value = ARR2
End With
With Sheets("кв3")
.Range("A1:F1").Value = R
.Cells(2, 1).Resize(UBound(ARR0), UBound(ARR0, 2)).Value = ARR3
End With
With Sheets("кв4")
.Range("A1:F1").Value = R
.Cells(2, 1).Resize(UBound(ARR0), UBound(ARR0, 2)).Value = ARR4
End With
T2 = Timer
Application.ScreenUpdating = True
MsgBox "Работа завершена " & Chr(13) & " Обработка  " & LR - 1 & "  строк  заняла " & Int(T2 - T1) & " секунд."
 
End Sub