Speed Up Macro

[nniedzielski]

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,

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]

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?

 

[nniedzielski]

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]

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:

Dim erow As Long
erow = Sheets("Data").UsedRange.Rows.Count + Sheets("Data").UsedRange.Row - 1

back to the way you had the assignment originally:

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]

​

As a reminder this kind of process should be easily & quickly achieved just with an advanced filter …​

 

[cmowla]

​

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]

​

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 …​