Speed Up Macro

nniedzielski

Well-known Member
Joined
Jan 8, 2016
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
Hello folks,

I am running a macro that creates a dictionary, then creates a tab for each unique value in the dictionary, then filters data for each dictionary value. Copies and pastes that data into one of the new tabs. It is taking forever to run, and i think the culprit is in the pasting, that seems to be where my computer starts to lag. Can anyone look at my code and see if you see any solutions i could add or remove or alter to get this to run at a reasonable speed? I am open to any and all solutions.

thanks all,

VBA Code:
Sheets("Data").Select
Columns("j").Select
Selection.Copy

Columns("z").Select
ActiveSheet.Paste
ActiveSheet.Range("$z$1:$z$10000").RemoveDuplicates Columns:=1, Header:=xlYes

Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant

Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")

With ActiveSheet

'show autofilter if not already shown on all rows
If Not .AutoFilterMode Then .UsedRange.AutoFilter
If .Cells.AutoFilter Then .Cells.AutoFilter

'Create list of unique items in column B that get filled into ArrayDictionaryofItems
Dim hamburger As Double

If Range("j3").Value <> "" Then
hamburger = 2
Items = Range(.Range("z2"), .Cells(Rows.Count, "z").End(xlUp))

For i = 1 To UBound(Items, 1)
ArrayDictionaryofItems(Items(i, 1)) = 1
Next

Else

Item = Range("j2").Value
hamburger = 1
End If

'Filter multiple items if hamburger is set to equal 2 because J3 is blank
If hamburger = 2 Then

For i = 1 To UBound(Items, 1)
Sheets.Add After:=Sheets(i)
Next i

Sheets("Data").Select

Dim x As Double
x = 2

For Each Item In ArrayDictionaryofItems.keys
erow = ActiveSheet.Cells(Rows.Count, 10).End(xlUp).Row
'autofilter on column b with this driver
.UsedRange.AutoFilter field:=10, Criteria1:=Item

Columns("A:Y").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

Sheets(x).Select
Columns("A:Y").Select
ActiveSheet.Paste
Sheets("Data").Select

x = x + 1
Next Item
GoTo LINE99:
End If
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
73,318
Office Version
  1. 365
Platform
  1. Windows
That means that, with all of the filters applied, it can happen that there is no rows to transfer.
Or is it that you are looking at the last row & not the entire data set?
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

nniedzielski

Well-known Member
Joined
Jan 8, 2016
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
Or is it that you are looking at the last row & not the entire data set?
Hi Fluff--

I made a small change to the line of code:

Range("A1" & ":" & "Y" & erow).SpecialCells(xlCellTypeVisible).Copy

And it kinda works, but about half of the filters when they copy, copy the same data over and over all the way down to erow, and i cannot figure out why,
 

cmowla

Board Regular
Joined
Sep 21, 2021
Messages
243
Office Version
  1. 365
Platform
  1. Windows
There is data to be copied, when the data is filtered, there is data on rows 2-6, 8, 384, 429, 487, 503, 549, 553, 769.

I can see the rows with data being filtered, but still get this error when i try to copy.
Okay, I believe I made an error earlier regarding erow.

So from my post before the last one (with all of the code), change:
VBA Code:
Dim erow As Long
erow = Sheets("Data").UsedRange.Rows.Count + Sheets("Data").UsedRange.Row - 1

back to the way you had the assignment originally:
VBA Code:
Dim erow As Long
erow = ActiveSheet.Cells(Rows.Count, 10).End(xlUp).Row

The problem could be that Column J has fewer items in it than other columns in the sheet. The value I assigned to erow was the number of items in the column with the most rows. That could explain why there are still more rows visible in the data in Column J, but the loop was still search for a large amount of rows than what Column J has filled.

(erow was the only thing I changed without full justification.)
 

Marc L

Banned User
Joined
Apr 5, 2021
Messages
2,030
Office Version
  1. 2010
Platform
  1. Windows
As a reminder this kind of process should be easily & quickly achieved just with an advanced filter …​
 

cmowla

Board Regular
Joined
Sep 21, 2021
Messages
243
Office Version
  1. 365
Platform
  1. Windows
As a reminder this kind of process should be easily & quickly achieved just with an advanced filter …​
That's a good idea if someone was looping and filtering out one item at a time in some cases, but can this really be done in this case? The data needs to be copied to different sheets. (That's what the loop is for: "Sheets(x)".)

The CopyToRange parameter, which I learned about from VBA Advanced Filter - Automate Excel , thanks, would most definitely be needed in our case.

(You cannot can do a Union() of ranges if they are from different sheets.)
 

Marc L

Banned User
Joined
Apr 5, 2021
Messages
2,030
Office Version
  1. 2010
Platform
  1. Windows
I often used this quick method instead of using a dictionary, filtering then copying like in the initial code​
and can be used here within a loop and easier to maintain for beginners or those asking for help on forums …​
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,323
Messages
5,836,637
Members
430,442
Latest member
Zephreo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top