Trying to speed up a VBA loop that applies a different autofilter on each iteration and copies/pastes filtered data to another worksheet

[WolfOctober]

Here's the code:

For i = 5 To 173 Step 7
Sheets("Data Sheet").Select
Columns("D:G").Select
Selection.AutoFilter
Sheets("Data Sheet").Range("D:G").AutoFilter Field:=4, Criteria1:="HBsAg"
Sheets("Data Sheet").Range("D:G").AutoFilter Field:=1, Criteria1:=Sheets("List of Sites").Range("B" & i)
Columns("E:E").Select
Selection.Copy
Worksheets("Data Sheet").AutoFilterMode = False
ActiveSheet.Paste Destination:=Worksheets("Test").Columns((i + 2) / 7)
Sheets("Test").Columns((i + 2) / 7).RemoveDuplicates Columns:=1, Header:=xlNo
Next i

Since I used Macro Recorder, the code includes .Select, .Copy, and .Paste, which I've been told are big no-nos when it comes to macro speed and efficiency. The above code works, but it's very slow...

Can someone help me modify the code such that it does not include these commands?

Thanks!

 

[JackDanIce]

With HBsAG filter outside of loop to reduce reapplying the same filter inside each loop iteration and with last row wrt to column E:

Sub Macro1()


    Dim x       As Long
    Dim y       As Long
    Dim LR      As Long
    Dim wSites  As Worksheet
    
    y = 1
    Set wSites = Sheets("List of Sites")
    
    Application.ScreenUpdating = False
    
    With Sheets("Data Sheet")
        LR = .Cells(.Rows.Count, 4).End(xlUp).row
        .Cells(1, 4).Resize(LR, 4).AutoFilter Field:=4, Criteria1:="HBsAg"
        For x = 5 To 173 Step 7
            .Cells(1, 4).Resize(LR, 4).AutoFilter Field:=1, Criteria1:=wSites.Cells(x, 2).Value
            .Cells(5, 1).Resize(LR).SpecialCells(xlCellTypeVisible).Copy
            With Sheets("Test")
                .Cells(1, y).PasteSpecial xlPasteValues
                .Cells(1, y).RemoveDuplicates Columns:=1, header:=xlNo
                y = y + 1
            End With
        Next x
    End With
                
    Application.ScreenUpdating = True
    
    Set wSites = Nothing
    
End Sub

 

[My Aswer Is This]

Glad to see you wrote him/her a whole new script.

With HBsAG filter outside of loop to reduce reapplying the same filter inside each loop iteration and with last row wrt to column E:

Sub Macro1()


    Dim x       As Long
    Dim y       As Long
    Dim LR      As Long
    Dim wSites  As Worksheet
    
    y = 1
    Set wSites = Sheets("List of Sites")
    
    Application.ScreenUpdating = False
    
    With Sheets("Data Sheet")
        LR = .Cells(.Rows.Count, 4).End(xlUp).row
        .Cells(1, 4).Resize(LR, 4).AutoFilter Field:=4, Criteria1:="HBsAg"
        For x = 5 To 173 Step 7
            .Cells(1, 4).Resize(LR, 4).AutoFilter Field:=1, Criteria1:=wSites.Cells(x, 2).Value
            .Cells(5, 1).Resize(LR).SpecialCells(xlCellTypeVisible).Copy
            With Sheets("Test")
                .Cells(1, y).PasteSpecial xlPasteValues
                .Cells(1, y).RemoveDuplicates Columns:=1, header:=xlNo
                y = y + 1
            End With
        Next x
    End With
                
    Application.ScreenUpdating = True
    
    Set wSites = Nothing
    
End Sub

 

[JackDanIce]

As suggested, taking one of the repeated filters outside of the loop would speed up the execution of the code, with respect to the original request of speeding the code up

Always trying to learn more and help others where I can

reading the code may have highlighted this with respect to your code.

 

[WolfOctober]

VBA: Is there any way to speed up this autofilter loop?

Hi all,

Through trial-and-error, I have determined that the following section of my larger code is causing my overall macro to run really slowly:

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

'Populating "HBsAg" with Average % IRR data    For j = 7 To 157
        For i = 1 To 77
            With Sheets("HBsAg")
                Sheets("Data Sheet").Select
                Columns("E:I").AutoFilter
                Sheets("Data Sheet").Range("E:I").AutoFilter Field:=3, Criteria1:="HBsAg"
                Sheets("Data Sheet").Range("E:I").AutoFilter Field:=1, Criteria1:=.Cells(j, 2)
                Sheets("Data Sheet").Range("E:I").AutoFilter Field:=5, Operator:=xlFilterValues, Criteria2:=Array(2, .Cells(6, i + 2))
                Dim filter_rng As Range
                Dim rw As Range
                Dim last_row As Long
                last_row = Cells(Rows.Count, "K").End(xlUp).Row
                Set filter_rng = Sheets("Data Sheet").Range("J1:K" & last_row)
                For Each rw In filter_rng.SpecialCells(xlCellTypeVisible)
                    Sheets("Test").Range("A" & rw.Row).Value = Sheets("Data Sheet").Range("J" & rw.Row).Value
                    Sheets("Test").Range("B" & rw.Row).Value = Sheets("Data Sheet").Range("K" & rw.Row).Value
                Next rw
                Worksheets("Data Sheet").AutoFilterMode = False
                If WorksheetFunction.CountA(Sheets("Test").Cells) = 0 Then
                    .Cells(j, i + 2) = vbNullString
                Else
                    .Cells(j, i + 2) = Application.WorksheetFunction.Sum(Sheets("Test").Columns("B:B")) / Application.WorksheetFunction.Sum(Sheets("Test").Columns("A:A")) * 100
                    .Cells(j, i + 2).NumberFormat = "0.000"
                End If
                Sheets("Test").Cells.Clear
            End With
        Next i
    Next j

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

Basically, here's what the loop does --
1) Based on values in the "HBsAg" worksheet, the loop applies a unique autofilter to the "Data Sheet" worksheet
2) Transfers that filtered data into the "Test" worksheet
3) Runs a calculation (dividing the sum of one column by another) on that data that was just transferred to "Test"...
4) ...And prints (and formats) the result of that into the corresponding (based on the autofilters applied in Step 1) cell in "HBsAg"

When I run the macro, it takes 20 minutes to complete...

Is it because there are basically 10,000+ autofilters being applied to "Data Sheet" throughout the course of the loop? Could it be something else that's slowing things down? What can I do to speed things up?

Thanks!

 

[Peter_SSs]

Re: VBA: Is there any way to speed up this autofilter loop?

This appears to be a continuation of another thread of yours, so I have combined them. Please refer to #12 of the Forum Rules and points 6 & 7 of the Forum Use Guidelines.

 

[ukmikeb]

Re: VBA: Is there any way to speed up this autofilter loop?

This appears to be a continuation of another thread of yours, so I have combined them. Please refer to #12 of the Forum Rules and points 6 & 7 of the Forum Use Guidelines.

Peter

Perhaps you should have closed that thread.

Here is my response to that thread referring to post #14


Possibly this statement :-

 .Cells(j, i + 2) = Application.WorksheetFunction.Sum(Sheets("Test").Columns("B:B")) / Application.WorksheetFunction.Sum(Sheets("Test").Columns("A:A")) * 100

Try to limit this calculation to the number of used rows.

hth

 

[Peter_SSs]

Re: VBA: Is there any way to speed up this autofilter loop?

Peter

Perhaps you should have closed that thread.

Mike, the two threads I had come across I merged into one (this one), effectively closing one of them. Are you saying there is yet another one? I don't have time to look now - perhaps you could provide a link?

 

[ukmikeb]

Re: VBA: Is there any way to speed up this autofilter loop?

Mike, the two threads I had come across I merged into one (this one), effectively closing one of them. Are you saying there is yet another one? I don't have time to look now - perhaps you could provide a link?

Peter

It appears that @RoryA closed the thread - https://www.mrexcel.com/forum/excel-questions/1021418-vba-autofilter-loop-running-too-slowly.html - after I had commented in this thread.

 

[Peter_SSs]

Re: VBA: Is there any way to speed up this autofilter loop?

It appears that @RoryA closed the thread

OK, thanks.