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!

 

[My Aswer Is This]

Normally when your using a Filter you do not need to use a loop.

It would be nice if you were to tell us in words what your wanting to do.

 

[WolfOctober]

Sure!

Basically, I have a master sheet ("Data Sheet") that contains all the data I need to populate every other sheet in the workbook.

This section of my code applies an autofilter(s) to "Data Sheet", copies the column containing the desired filtered data, and pastes it in a column on a separate sheet.

The reason I used a loop is because the autofilter that needs to be applied to "Data Sheet" is different every time.

For example, the first iteration applies autofilter criteria 1, copies the filtered data from column E in "Data Sheet", and pastes to column A in another worksheet.
The next iteration applies autofilter criteria 2, copies the filtered data from column E in "Data Sheet", and pastes to column B in another worksheet.
And this continues for 25 iterations...

The code works, but it's very slow and I think it's because I'm using .Select, .Copy, and .Paste in my code.

 

[My Aswer Is This]

But if you want the selections removed try this.

Sub My_Script()
For i = 5 To 173 Step 7
Sheets("Data Sheet").Select
Columns("D:G").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").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
End Sub

This line of code is attempting to copy 1.5 millions cells. Which could surely slow things down.

Columns("E:E").Copy

 

[JackDanIce]

Welcome to the board.

Your current code is filtering through Data Sheet, using filter values from List of Sites and then pasting the results to Test, starting at Column A and then moving to the right.

You're always filtering column G for HBsAG, before filtering for the List of Sites values in column D, so you could apply the column G filter outside of the loop, to reduce the number of times it's applied.

Can you explain why you need to use Step 7 or why List of Sites has the filter values separated by 7 rows for search filter value?

It may help to describe your set up more clearly as readers of the thread can't see your PC monitor as you can.

 

[My Aswer Is This]

I see nothing in your code that does this:

"Basically, I have a master sheet ("Data Sheet") that contains all the data I need to populate every other sheet in the workbook."


I only see two different sheets being mentioned here.

 

[WolfOctober]

This is only one section of a longer code. Through trial and error, I have determined that this is the section of the code that is slowing me down.

Btw, your last post definitely cut down the run time a bit. Thanks!

 

[WolfOctober]

"This line of code is attempting to copy 1.5 millions cells. Which could surely slow things down."

That's a good point. I'll probably have to do a last row finder thingamagig

 

[My Aswer Is This]

Also try changing this:
Now it only copies to the last cell with data and not all 1.5 million cells

'old way Columns("E:E").Copy
'New way:

Range("E1:E" & Cells(Rows.Count, "E").End(xlUp).Row).Copy

 

[WolfOctober]

Bro, you're killing it!

That shaved a lot of time off. Thanks!