nniedzielski
Well-known Member
- Joined
- Jan 8, 2016
- Messages
- 598
- Office Version
- 2019
- Platform
- 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,
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