Paste from 1 sheet to all sheets in a sheet range then delete rows on all sheets within sheet range based on a filter

[chappy]

I would like to do the following:

1. Copy a fixed data range (A6:AN6000) from a sheet ("SOURCE") to ALL sheets within a defined sheet range.
2. Filter the rows in the sheet range to only those containing "0" in column "AO". The sheets within the sheet range have formula in the next column outside the paste range ("AO6:AO5000") that sets a "1" or "0" based on the following formula

   ((AND($R6>=$R$2,$R6<=$R$3-0.001))+0)

3. Delete the filtered rows containing the "0" value in column "AO"
4. Reset the filter in column "AO" to "1" to show the remaining data.

I have tried to use the code below. However:

• It deletes ALL rows (not just the filtered rows).
• It is also very slow. In this example I have reduced the number of sheets for simplicity but the live version has considerably more sheets in the sheet range which would make it even slower.

If anyone could offer any advice on where this is going wrong and any suggestion to improve the efficiency to speed up the steps it would be most appreciated.

Sub Filter_delete()
   
    'Switch off auto calculate to speed up
    Application.Calculation = xlManual
   
    'Switch off screen updating to hide the macro function from being visible - remove this line if you want to see it
    Application.ScreenUpdating = False
       
    Dim ws As Worksheet
   
        'SET The Sheet Names - MUST Reflect Each Sheet Name Exactly!
        WkSheets = Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+")
   
        'Copy & Paste source data to all sheets in the
        Sheets("SOURCE").Select
        Range("A6:AN5000").Copy
       
        Sheets(Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+")). _
        Select
        Range("A6").Select
        ActiveSheet.Paste
  
    For Each ws In Sheets(Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+"))
        'Field 41 = column "AO"
        ws.Range("$A$5:$AO$5000").AutoFilter Field:=41, Criteria1:="0"
        ActiveSheet.Calculate
        Rows("6:5000").Select
        Selection.Delete Shift:=xlUp
        ws.Range("$A$5:$AO$5000").AutoFilter Field:=41
    Next

End Sub

 

[chappy]

Corrections to the above post:

Copy a fixed data range (A6:AO6000) from a sheet ("SOURCE") to ALL sheets within a defined sheet range.

Formula in colum "AO" on the "SOURCE" sheet.

=((AND($R7>=$R$2,$R7<=$R$3-0.001))+0)

Revised code:

Sub Filter_delete()
    
    Dim ws As Worksheet
    
        'SET The Sheet Names - MUST Reflect Each Sheet Name Exactly!
        WkSheets = Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+")
    
        'Copy & Paste source data to all sheets in the
        Sheets("SOURCE").Select
        Range("A6:AO4642").Copy
        
        Sheets(Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+")). _
        Select
        Range("A6").Select
        ActiveSheet.Paste
        Calculate
           
    For Each ws In Sheets(Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+"))
        ws.Range("$A$5:$AO$4642").AutoFilter Field:=41, Criteria1:="0"
        Range("AO6").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.EntireRow.Delete
        ActiveSheet.Range("$A$5:$AO$4642").AutoFilter Field:=41, Criteria1:="1"
    Next
    
End Sub

The code does not loop through all the sheets in the sheet range

 

[chappy]

I have revised the code to try a different approach. The code works for the first sheet but does not loop through to the next sheets. Any help to resolve this would be much appreciated.

Option Explicit 'Very first line ensures that every variable is declared properly.


Sub Filter_delete()
    
        
    Dim wSheetArray As Sheets
    Dim wSheet As Worksheet
    Dim SourceData As Range
    Dim PasteCell As Range
    Dim FilterRange As Range
    Dim FilterCell As Range
    Dim LastRow As Long
   
    Set SourceData = ActiveWorkbook.Sheets("Source").Range("A6:AO4642")
    Set wSheetArray = ActiveWorkbook.Sheets(Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+", "P 50-500 G 5+"))
    Set PasteCell = Range("A6")
    Set FilterRange = ActiveSheet.Range("AO6:AO4642")
           
    Application.Calculation = xlManual
    
    Application.ScreenUpdating = False
    
        'Copy Source Data
        SourceData.Copy
        
        'Select the sheets in the wSheetArray (as defined above)
        wSheetArray.Select
        Range("A6").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
        Range("A6").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
        ActiveSheet.Select
        
            For Each wSheet In wSheetArray
            
                wSheet.Calculate
                Range("AO6").Select
                Range(Selection, Selection.End(xlDown)).Select
                FilterRange.AutoFilter Field:=1, Criteria1:="0"
                Range("AO6").Select
                Range(Selection, Selection.End(xlDown)).Select
                Selection.SpecialCells _
                (xlCellTypeVisible).EntireRow.Delete
            
            Next wSheet

End Sub

 

[Alex Blakenburg]

On a copy of your workbook see if replacing your for each loop with this does what you need.
Also change your wSheet statement to this

    Dim wSheet As Worksheet

            Dim lastRow As Long
        
            For Each wSheet In wSheetArray
                With wSheet
                    .Calculate
                    lastRow = .Cells(6, "AO").End(xlDown).Row
                    Set FilterRange = .Range("AO6:AO" & lastRow)
                    FilterRange.AutoFilter Field:=1, Criteria1:="0"
                    FilterRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End With
            
            Next wSheet

 

[vcoolio]

Hello Chappy,

See if the following modified version of your code helps:-

Option Explicit
Sub Filter_delete()
  
    Dim wsS As Worksheet: Set wsS = Sheets("Source")
    Dim ar As Variant: ar = Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+", "P 50-500 G 5+")
    Dim i As Long, sh As Worksheet
         
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
  
    For i = 0 To UBound(ar)
            Set sh = Sheets(ar(i))
            wsS.Range("A6:AO4642").Copy
            sh.[A6].PasteSpecial xlPasteAll
            With sh.Range("AO6", sh.Range("AO" & sh.Rows.Count).End(xlUp))
                    .AutoFilter 1, 0#
                    .Offset(1).EntireRow.Delete
                    .AutoFilter
            End With
    Next i
  
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

 

[chappy]

Thanks to you both for your responses. It is very much appreciated.

I have adjusted slightly. Column AO needs to calculate for the filter to work correctly. I also pasted values into the other columns in an attempt to maintain speed.

The code works but is very slow. Would you have any advice on how to speed things up? The deletion of the filtered rows is the element that really slows things down.

Many thanks again for your help Alex & vcoolio!

Option Explicit 'Very first line ensures that every variable is declared properly.

Sub Filter_delete()

    
    Dim wsS As Worksheet: Set wsS = Sheets("Source")
    Dim ar As Variant: ar = Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+", "P 50-500 G 5+")

    Dim i As Long, sh As Worksheet
         
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
  
    For i = 0 To UBound(ar)
            Set sh = Sheets(ar(i))
            wsS.Range("A6:AO4642").Copy
            sh.[A6].PasteSpecial xlPasteAll
            wsS.Range("A6:AN4642").Copy
            sh.[A6].PasteSpecial xlPasteValues
            sh.Calculate
            With sh.Range("AO5", sh.Range("AO" & sh.Rows.Count).End(xlUp))
                    .AutoFilter 1, 0#
                    .Offset(1).EntireRow.Delete
                    .AutoFilter
            End With
    Next i
  
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[Alex Blakenburg]

Did you try @vcoolio's code ? Is it still slow with his turning off screen updating and turning off calculations ?
I understand you need it to calculate prior to filtering but having it off while deleting should help.

How many records are there in each sheet and what sort of numbers are being deleted ?
Can you post an XL2BB of some sample data for use to expirement on ?
It may be faster to create a helper column (can be done with code) and sorting the rows to be deleted together prior to deletion.
You could even try that manually first. If consolidating the lines to be deleted and then deleting them doesn't seem to make a difference to the speed then it will save us writing code that isn't going to help anyway.

 

[chappy]

Yes I tried vcoolio's code and adjusted it slightly.

It is slow with the screen updating switched off and calculation turned off.
I include formula in column AO which is used by the filter, essentially that is a formula-based helper column. I had hoped that using the excel filter function would be the most efficient method to filter prior to the deletion.
All of the other data on the sheet is pasted in as values. There is colour formatting on the sheets as well.
In the largest sheet the data range extends to 2000+ rows, with data in 80,000+ cells.
I can't install the L2BB add-in on the machine I am using currently, but will do it on my own pc later.
The copy and paste element to the code is done on all sheets so could be done only with all sheets grouped rather than for each each sheet in the loop through the sheets, but that part doesn't seem to take the time. It really seems to stall on the deletion of the filtered rows.

I have just tried manually and you are right, trying to delete the rows filtered with "0" value is extremely slow. There is no point in trying to help write more code when the issue is excel takes a long time to delete large filtered areas. Instead I should try to sort the data first so that the rows with value "0" in column "AO" appear all together and can be selected then deleted.

 

[Alex Blakenburg]

I have made 2 changes to what was my loop. You should be able to do similar thing with vcoolio's code.
Note: I have not specified a full range so it relies on Sort identifying the current region which means you can't have any fully empty columns or rows in the middle of your data.

See if this improves the speed.

            For Each wSheet In wSheetArray
                With wSheet
                    .Calculate
                    lastRow = .Cells(6, "AO").End(xlDown).Row
                    Set FilterRange = .Range("AO6:AO" & lastRow)
                    ' XXX Add sort > Relies there being no blank columns or rows
                    .Range("AO6").Sort Key1:=.Range("AO6"), Order1:=xlDescending 
                    FilterRange.AutoFilter Field:=1, Criteria1:="0"
                    ' XXX added Offset to avoid deleting headings
                    FilterRange.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End With
            
            Next wSheet

 

[vcoolio]

Hello Chappy,

Just following on from Alex's comments:

I created a sample of what I assume your workbook looks like including your sheet names and the same amount of data as you've mentioned in previous posts. The run time was less than half a second. However, having said that, I did not have any formulae in the sample. I'm assuming that the formula you posted in post #1 is the only formula you are using and is only in Column AO.

Firstly, remove the these additional lines of code that you added:-

wsS.Range("A6:AN4642").Copy
sh.[A6].PasteSpecial xlPasteValues

They are not necessary and will further delay the run time. The 'PasteAll' does exactly as it says including values.

Secondly, try the code amended as follows. It is broken up into separate steps to help improve efficiency.

Option Explicit
Sub Filter_delete()
  
        Dim wsS As Worksheet: Set wsS = Sheets("Source")
        Dim ar As Variant: ar = Array("P<5 G 0+", "P 5-10 G 0+", "P 5-10", "P 5-10 G 2+", "P 5-10 G 5+", "P 50-500 G 5+")
        Dim i As Long, sh As Worksheet
         
Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
  
        For i = 0 To UBound(ar)
                Set sh = Sheets(ar(i))
                wsS.Range("A6:AO4642").Copy
                sh.[A6].PasteSpecial xlPasteAll
                With sh.Range("AO6", sh.Range("AO" & sh.Rows.Count).End(xlUp))
                        .Calculate
                End With
                
                Application.Calculation = xlCalculationManual
                
                With sh.Range("A6", sh.Range("AO" & sh.Rows.Count).End(xlUp))
                       .Sort sh.[AO6], 1 '---->Sorting will group zero values at the top of the data set.
                End With
                With sh.Range("AO5", sh.Range("AO" & sh.Rows.Count).End(xlUp))
                        .AutoFilter 1, 0#
                        .Offset(1).EntireRow.Delete
                        .AutoFilter
                End With
        Next i
  
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Another option for the above code is to make an adjustment to the 'PasteSpecial" method. Hence, also test it by changing this:

wsS.Range("A6:AO4642").Copy
sh.[A6].PasteSpecial xlPasteAll

to

wsS.Range("A6:AO4642").Copy
sh.[A6].PasteSpecial xlValues
wsS.Range("A6:AO4642").Copy
sh.[A6].PasteSpecial xlPasteFormulas

This will only paste values and formulae leaving everything else behind including formatting which really slows down a procedure.

Cheerio,
vcoolio.