Clear Cells takes forever when sheet is shared

[jynxy]

Hi,

When running the following, the sheet runs through the first time no problem as there is no data, once data is in the sheet this then takes forever to clear, i have tried usedrange and selection a smaller range manually, neither makes a difference, i have also tried this with just one sheet which is also the same.

Soon as i remove this code it works fine. Why does this keep happening ?

Application.EnableEvents = False
Application.Calculation = xlManual
For N = 1 To 9
    With wb.Sheets("Day" & N)
        If .AutoFilterMode = True Then .AutoFilterMode = False
        Range("A1:G25000").Clear
    End With
Next
Application.Calculation = xlAutomatic
Application.EnableEvents = True

The rest of the sheet is at present

    With Workbooks(CopyFile).Sheets(CopyFileName).UsedRange
        .AutoFilter Field:=1, Criteria1:="<>" & MyCriteria
        .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilter
        Range("A1").Select
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.Copy
    End With

    For N = 1 To 9
        With wb.Sheets("Day" & N)
            .Activate
            Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        End With
    Next

    Application.CutCopyMode = False
    Workbooks(CopyFile).Close savechanges:=False

 

[jynxy]

Looks like i spent ages thinking it the clear section but i now believe its the copy paste section.

 

[MARK858]

See if the code below does what you want and is faster. Test on copies of your workbooks

  With Workbooks(CopyFile).Sheets(CopyFileName)
        With .UsedRange
            .AutoFilter Field:=1, Criteria1:="<>" & MyCriteria
            .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilter
        End With
        .Range("A1").CurrentRegion.Copy
    End With

    For N = 1 To 9
        With wb.Sheets("Day" & N)
            .Range("A1").PasteSpecial Paste:=xlPasteAll
        End With
    Next

    Application.CutCopyMode = False
    Workbooks(CopyFile).Close savechanges:=False

 

[jynxy]

@MARK858 Thanks for the above, i have inputed that and seems to work so thanks for the shortened version, however the second time i run the code it takes forever to do as always , shows Cell (press esc) message at the bottom. its like its not clearing something.

Below is the full code, i have changed some names.

Sub Macro4()

Dim MyDate As String
Dim MyTime As String
Dim MyFile As String
Dim MyCriteria As String
Dim WFile As String
Dim CopyFile As String
Dim CopyFile1 As String
Dim BackupCopy As String
Dim dt As Date
Dim dt2 As Date

Dim FSO As Object

Set wb = ThisWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")

MyDate = Format(Now, "DD.MM.YY")
MyTime = Format(Now, "HH.MM.SS")
MyFile = ThisWorkbook.Name

MyCriteria = ThisWorkbook.Sheets("Settings").Range("F1").Value
WFile = "file_export.csv"
CopyFile = "file.csv"
CopyFile1 = "copy"
BackupCopy = "file_backup.csv"

'dt = Format(wb.Sheets("Dotcom").Range("F1"), "dd/mm/yyyy")
dt = wb.Sheets("Dotcom").Range("F1")
dt2 = dt - 1

'Now2 = CDate(Now() - 1) 'formatting the date using the CDate function
'Now2 = Format(Now2, "MM/DD/YYYY") 'formatting the date by dropping the hour

'dt2 = CDate(dt2) 'formatting the date using the CDate function
'dt2 = Format(dt2, "MM/DD/YYYY") 'formatting the date by dropping the hour

Application.EnableEvents = False
Application.Calculation = xlManual
For N = 1 To 9
    With wb.Sheets("Day" & N)
        .UsedRange.Columns("A:G").Clear
    End With
Next

Application.Calculation = xlAutomatic
Application.EnableEvents = True
Application.CutCopyMode = False
    
    Workbooks.Open ("c:\scripts\" & CopyFile)

  With Workbooks(CopyFile).Sheets(CopyFile1)
        With .UsedRange
            .AutoFilter Field:=1, Criteria1:="<>" & MyCriteria
            .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilter
        End With
        .Range("A1").CurrentRegion.Copy
    End With

    For N = 1 To 9
        With wb.Sheets("Day" & N)
            .Range("A1").PasteSpecial Paste:=xlPasteAll
        End With
    Next
    
    Application.CutCopyMode = False
    Workbooks(CopyFile).Close savechanges:=False

    For N = 1 To 9
        With wb.Sheets("Day" & N)
            With .UsedRange.Columns("A:G")
                .AutoFilter Field:=5, Criteria1:="<" & CLng(dt2), _
                 Operator:=xlOr, Criteria2:=">=" & CLng(dt2) + 1
                .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilter
           End With

           dt2 = dt2 + 1
       End With
       Next

End Sub