automatically move data to another worksheet

Private Sub CommandButton1_Click()
    Dim lr As Long, n As Long
    Dim CpyRng As Range, CpyToRng As Range, rRngToClear As Range

    With Application
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    With Sheets("Overview").Range("A1:D35")
        For i = 2 To Worksheets.Count - 3
            lr = Sheets(Sheets(i).Name).Range("A" & Rows.Count).End(xlUp).Row + 1
            .AutoFilter 4, Sheets(i).Name
            n = Range("A1:D35").SpecialCells(12).SpecialCells(2).Count

            If n > 4 Then
                'Setup the Ranges to Copy From and To
                Set CpyRng = Sheets("Overview").Range("A1").CurrentRegion.Offset(1).SpecialCells(12)
                Set CpyToRng = Sheets(Sheets(i).Name).Range("A" & lr)
                CpyRng.Copy Destination:=CpyToRng

                'Build Range that will be cleared
                If rRngToClear Is Nothing Then
                    Set rRngToClear = CpyRng
                Else
                    Set rRngToClear = Union(rRngToClear, CpyRng)
                End If
            End If
        Next i
        ' Clear the rows that were transferred
        If Not rRngToClear Is Nothing Then
            rRngToClear.ClearContents
        End If

        .AutoFilter
    End With
    Cells(2, 2).Select
    With Application
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A35")) Is Nothing Then
        CalendarFrm.Show
    End If
End Sub

For i = 2 To Worksheets.Count - 3