VBA to filter then delete visible rows running slower with subsequent uses

[Tphil413]

The macro below is one that I use to break a large excel file (>40MB) into smaller files used by different teams. I run the macro below to filter out data in 5 worksheets that is not needed by a particular team which shrinks the files to under 5MB making them easier to use. The first four worksheets are all 70,000 rows of data downloaded from our planning system. The macro auto-filters then deletes about 1/3 to 2/3 of the rows. The last worksheet holds the lookup tables that drive the values in columns A and B on the four worksheets used to filter and delete. The VBA filters column A looking for "0" rows to be deleted, then it deletes the visible rows and finally removes the filter to show the remaining rows. I have a bit of a mystery I'm trying to solve. When the code runs initially it runs in 20 seconds which is great, but once I run it a few times to create files for different teams, the code slows to 5-7 minutes as excel stops responding. When I look at the task list excel is using 95-97% of memory. I've stepped through the code and when it slows, its on the "SpecialCells(xlCellTypeVisible).EntireRow.Delete" line. I can't figure out why the code runs so cleanly initially then uses so much memory on subsequent attempts. Do I need to include code to clear the excel cache? I don't think I'm using the clipboard when I'm filtering, but should I try to clear the clipboard? Any ideas or suggestions are appreciated, this one has me stumped.

Sub Delete_Rows_Based_On_Value()
'
'Apply a filter to a Range and delete visible rows
'
Application.ScreenUpdating = False
Application.Calculation = xlManual

Dim ws As Worksheet

  Set ws = ThisWorkbook.Worksheets("Current Fcst")
   ws.Activate
   ws.Range("$A$3:$A$70000").Calculate
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0
    ws.Range("$A$2:$W$70000").AutoFilter Field:=1, Criteria1:="=0"
    ws.Range("$A$3:$W$70000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ws.AutoFilterMode = False
 
  Set ws = ThisWorkbook.Worksheets("Prior Fcst")
  ws.Activate
  ws.Range("$A$3:$A$70000").Calculate
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0
    ws.Range("$A$2:$W$70000").AutoFilter Field:=1, Criteria1:="=0"
    ws.Range("$A$3:$W$70000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ws.AutoFilterMode = False
 
  Set ws = ThisWorkbook.Worksheets("Budget")
   ws.Activate
   ws.Range("$A$3:$A$70000").Calculate
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0
   ws.Range("$A$2:$W$70000").AutoFilter Field:=1, Criteria1:="=0"
   ws.Range("$A$3:$W$70000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
   ws.AutoFilterMode = False
 
  Set ws = ThisWorkbook.Worksheets("Prior Year")
   ws.Activate
   ws.Range("$A$3:$A$70000").Calculate
  On Error Resume Next
   ws.ShowAllData
  On Error GoTo 0
   ws.Range("$A$2:$W$70000").AutoFilter Field:=1, Criteria1:="=0"
   ws.Range("$A$3:$W$70000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
   ws.AutoFilterMode = False
 
  Set ws = ThisWorkbook.Worksheets("Drop Downs")
   ws.Activate
   ws.Range("$A$18:$A$150").Calculate
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0
   ws.Range("$A$17:$C$150").AutoFilter Field:=1, Criteria1:="0"
   ws.Range("$A$18:$C$150").SpecialCells(xlCellTypeVisible).EntireRow.Delete
   ws.AutoFilterMode = False

  Application.ScreenUpdating = True

End Sub

 

[Akuini]

@Tphil413, welcome to MrExcel.
Deleting large non-contiguous rows is slow, try using ".ClearContents" instead of ".Delete". And then you can sort the data to "remove" the blank rows.

ws.Range("$A$3:$W$70000").SpecialCells(xlCellTypeVisible).EntireRow.ClearContents

 

[johnnyL]

Hold on ...

 

[johnnyL]

Sorry about that, I forgot to add in some of the original code.

Here is the approach I took to accomplish the goal:

Sub DeleteRowsStartingWithZero()
'
    Dim ArrayRow                    As Long
    Dim HelperColumnNumber          As Long
    Dim ZerosCount                  As Long
    Dim ManualCalculateEndAddress   As String, ManualCalculateOtherEndAddress   As String
    Dim DataEndAddress              As String, DataStartAddress                 As String
    Dim DataOtherEndAddress         As String, DataOtherStartAddress            As String
    Dim InputArray                  As Variant, ZeroRowFoundArray               As Variant
    Dim sheetNamesArray             As Variant
    Dim ws                          As Worksheet
'
    Application.ScreenUpdating = False                                                      ' Turn ScreenUpdating off
    Application.Calculation = xlManual                                                      ' Turn AutoCalculations off
'
    DataEndAddress = "W70000"                                                               ' <--- Set this to the ending address of Data to be processed
    DataStartAddress = "A2"                                                                 ' <--- Set this to the start address of Data to be processed
    DataOtherEndAddress = "C150"                                                            ' <--- Set this to the ending address of Data to be processed
    DataOtherStartAddress = "A17"                                                           ' <--- Set this to the start address of Data to be processed
    ManualCalculateEndAddress = "A70000"                                                    ' <--- Set this to the ending address of Man calc address
    ManualCalculateOtherEndAddress = "A150"                                                 ' <--- Set this to the ending address of Other Man calc address
    sheetNamesArray = Array("Current Fcst", "Prior Fcst", "Budget", "Prior Year", "Drop Downs") ' <--- Set names of sheets to process into sheetNamesArray
'
    For Each sheetname In sheetNamesArray                                                   ' Loop through the designated sheet names
        ZerosCount = 0                                                                      '   Initialize ZerosCount to zero
        Set ws = Sheets(sheetname)                                                          '   Set the sheet name to process
'
        With ws
            HelperColumnNumber = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1       '   Get first empty column # at the end of used range
'
            If sheetname <> "Drop Downs" Then                                               '
                ws.Range(DataStartAddress & ":" & ManualCalculateEndAddress).Calculate      '
                InputArray = .Range(DataStartAddress, .Range(DataEndAddress)).Value         '           Load data from sheet into InputArray
            Else                                                                            '       Else ...
                ws.Range(DataOtherStartAddress & ":" & ManualCalculateOtherEndAddress).Calculate    '
                InputArray = .Range(DataOtherStartAddress, .Range(DataOtherEndAddress)).Value   '           Load data from sheet into InputArray
            End If
'
            ReDim ZeroRowFoundArray(1 To UBound(InputArray, 1), 1 To 1)                     '   Set the size of the ZeroRowFoundArray
'
            For ArrayRow = 1 To UBound(InputArray, 1)                                       '   Loop through rows of the InputArray
                If InputArray(ArrayRow, 1) = "0" Then                                       '       If row in Column A = 0 then ...
                    ZeroRowFoundArray(ArrayRow, 1) = 0                                      '           Set ZeroRowFoundArray row = 0
                    ZerosCount = ZerosCount + 1                                             '           Increment ZerosCount
                End If
            Next                                                                            '   Loop back
'
            If ZerosCount > 0 Then                                                          '   If zeros were found in Column A then ...
                If sheetname <> "Drop Downs" Then                                               '
                    With .Range(DataStartAddress).Resize(UBound(InputArray), HelperColumnNumber) '
                        .Columns(HelperColumnNumber).Value = ZeroRowFoundArray              '           Display ZeroRowFoundArray to HelperColumn
                        .Sort Key1:=.Columns(HelperColumnNumber), _
                                Order1:=xlAscending, Header:=xlNo                           '           Sort the rows according to values in HelperColumn
                        .Resize(ZerosCount).EntireRow.Delete                                '           Delete # of rows that were found to start with zero
                    End With
                Else                                                                                    '
                    With .Range(DataOtherStartAddress).Resize(UBound(InputArray), HelperColumnNumber)    '
                        .Columns(HelperColumnNumber).Value = ZeroRowFoundArray              '           Display ZeroRowFoundArray to HelperColumn
                        .Sort Key1:=.Columns(HelperColumnNumber), _
                                Order1:=xlAscending, Header:=xlNo                           '           Sort the rows according to values in HelperColumn
                        .Resize(ZerosCount).EntireRow.Delete                                '           Delete # of rows that were found to start with zero
                    End With
                End If
'
            End If
        End With
    Next                                                                                    ' Loop back to process next sheet
'
    Application.Calculation = xlAutomatic                                                   ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                       ' Turn ScreenUpdating back on
End Sub

 

[Tphil413]

Thanks so much JohnnyL and Akuini, both look like possible approaches, but as I said I have code that is capable of running in 20 seconds, so not sure I wanted to start with a new approach before analyzing why my current code is at times running 6-7 minutes. Any thoughts regarding what my code is doing in terms of its impact on memory and possible ways to mitigate that memory issue?

 

[johnnyL]

I think @Akuini already addressed an issue. With the way you have your code, the more rows you have to delete, the longer it is going to take.

You should at least try the suggestions that are offered to you.

 

[Tphil413]

@Akuini thanks for the code, I tried it and it did work fine, but ran a little over 10 minutes so I'm probably going to keep working with the code base I started with that runs faster and see if I can 1) sort the rows I plan to delete to be in one contiguous block, 2) then resort to the original order. Any suggestions regarding the best way to code something like that? Would I need to add a helper column to make the resort work? Any suggestions are definitely appreciated.

 

[johnnyL]

Did you try the code from post #4? It does what you are asking about.