Shortening my script

[stooven]

Hello!
With help from Norie and your archives, I was able to produce a working script for automating a task in my office. My only issue is that my script takes a long time to run. (I run it on very large spreadsheets) I was hoping someone could help me find a way to shorten my runtime while keeping exactly the same output. Any help would be greatly appreciated.

This is my script:

Sub Zeroremover()
Dim cell As Range
Dim aRange As Range
Set aRange = Range(Range("I1"), Range("I65536").End(xlUp))

    For Each cell In aRange
        If cell.Value <> "0" Then
            cell.EntireRow.Hidden = True
        End If
    Next cell
    
    aRange.SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Sheet2").Range("A1")
    aRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
    aRange.Cells.EntireRow.Hidden = False
    
End Sub

Thanks!
Steve

 

[Jon von der Heyden]

I had the same problem not so long ago - the reason it takes so long is because you're using a loop. Seems to me as though perhaps using auto-filter is a viable solution.

See attached post where I had a similar event and notice how Richard's suggested method using auto-filter is applied. You should be able to adapt to your needs.

http://www.mrexcel.com/board2/viewtopic.php?t=192430

Regards,
Jon

 

[stooven]

Thank you very much, Jon. Seems a little tricky yet only because this is my second day ever using VBA but I shall try and hopefully learn something. =-)

Steve

 

[stooven]

Thank you SO much Jon and Norie! I cut the loop out and changed my above code to the following:

Sub Zerobuster()
Dim cell As Range
Dim aRange As Range
Set aRange = Range(Range("I2"), Range("I65536").End(xlUp))

    Selection.AutoFilter
    Selection.AutoFilter Field:=9, Criteria1:="0"
    
    aRange.SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Sheet2").Range("A1")
    aRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
    aRange.Cells.EntireRow.Hidden = False
    
Dim bRange As Range
Set bRange = Range(Range("D2"), Range("D65536").End(xlUp))

    Selection.AutoFilter
    Selection.AutoFilter Field:=4, Criteria1:="0"
    
    bRange.SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Sheet3").Range("A1")
    bRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
    bRange.Cells.EntireRow.Hidden = False

Selection.AutoFilter
    
End Sub

It works perfectly and cut my processing time from several minutes to a fraction of a second!

Thanks again,
Steve

 

[Jon von der Heyden]

Brilliant Steve! Well done! You're a natural!

 

[Norie]

Steve

You could probably cut the time down further by not using Selection.

In fact you might be able to use Advanced Filter instead of AutoFilter, but I'm not sure about that because I can't remember fully what the original thread was about.

Could you post a link to it?

Looking at the code it appears this is what you are doing.

1 Copying every row that has a zero in column I to sheet 2.

2 Copying every row that has a zero in column D to sheet 3.

Is that about right?