Speed Up Macro

nniedzielski

Well-known Member
Joined
Jan 8, 2016
Messages
590
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
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Is it important to copy formatting or just the values?
 
Upvote 0
there is some dates in there that i would need moved over properly, so should keep formatting if i can, if its faster to just reformat later i could do that.
 
Upvote 0
Please make a copy of your Excel Workbook and run the following to see if it does the same as yours. (It should do things exactly, but I don't have time or the real means to verify right now.)

(Note: I did not see an "End Sub" line your code. If that's not the only line that you missed, you need to provide the rest of the code.)

But basically, avoid select when copying AND do not copy an entire column if unnecessary. The variable erow was defined in your code but never used. So I used it to function as the "last used row" in the sheet "Data". So you only copy a part of the columns A-Y.

VBA Code:
Sub unnamed_Sub()

Sheets("Data").Select

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

Range("J1:J" & erow).Copy
Range("Z1:Z" & erow).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False

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

Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant
Dim hamburger As Double, x As Double

Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")

With Sheets("Data")
  
    If Not .AutoFilterMode Then .UsedRange.AutoFilter
    If .Cells.AutoFilter Then .Cells.AutoFilter
      
    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
  
End With

If hamburger = 2 Then

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

    x = 2
    For Each Item In ArrayDictionaryofItems.keys

        Sheets("Data").UsedRange.AutoFilter field:=10, Criteria1:=Item
      
        Range("A" & erow & ":" & "Y" & erow).SpecialCells(xlCellTypeVisible).Copy
        Sheets(x).Range("A" & erow & ":" & "Y" & erow).PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
      
        x = x + 1
    Next Item

End If

End Sub
 
Upvote 0
Please make a copy of your Excel Workbook and run the following to see if it does the same as yours. (It should do things exactly, but I don't have time or the real means to verify right now.)

(Note: I did not see an "End Sub" line your code. If that's not the only line that you missed, you need to provide the rest of the code.)

But basically, avoid select when copying AND do not copy an entire column if unnecessary. The variable erow was defined in your code but never used. So I used it to function as the "last used row" in the sheet "Data". So you only copy a part of the columns A-Y.

VBA Code:
Sub unnamed_Sub()

Sheets("Data").Select

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

Range("J1:J" & erow).Copy
Range("Z1:Z" & erow).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False

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

Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant
Dim hamburger As Double, x As Double

Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")

With Sheets("Data")
 
    If Not .AutoFilterMode Then .UsedRange.AutoFilter
    If .Cells.AutoFilter Then .Cells.AutoFilter
     
    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
 
End With

If hamburger = 2 Then

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

    x = 2
    For Each Item In ArrayDictionaryofItems.keys

        Sheets("Data").UsedRange.AutoFilter field:=10, Criteria1:=Item
     
        Range("A" & erow & ":" & "Y" & erow).SpecialCells(xlCellTypeVisible).Copy
        Sheets(x).Range("A" & erow & ":" & "Y" & erow).PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
     
        x = x + 1
    Next Item

End If

End Sub
very sorry, here is the rest of the code:

VBA Code:
'Filter a single item in column since J3 is blank and there is only one item in column B to filter
If annoying = 1 Then

Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Select

Item = Range("B2").Value
.UsedRange.AutoFilter field:=2, Criteria1:=Item
End If

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

Sheets(2).Select
Columns("A:B").Select
ActiveSheet.Paste
Sheets("Sheet1").Select

End With

LINE99:
With ActiveSheet
If .AutoFilterMode Then .UsedRange.AutoFilter
End With

End Sub
 
Upvote 0
Okay, try this:
VBA Code:
Sub unnamed_Sub2()

Sheets("Data").Select

Dim erow As Long
erow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1

Range("J1:J" & erow).Copy
Range("Z1:Z" & erow).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False

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

Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant
Dim hamburger As Double, x As Double

Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")

With ActiveSheet

    If Not .AutoFilterMode Then .UsedRange.AutoFilter
    If .Cells.AutoFilter Then .Cells.AutoFilter
       
    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
   
   
    If hamburger = 2 Then
   
        For i = 1 To UBound(Items, 1)
            Sheets.Add After:=Sheets(i)
        Next i
       
        Sheets("Data").Select
   
        x = 2
        For Each Item In ArrayDictionaryofItems.keys
   
            Sheets("Data").UsedRange.AutoFilter field:=10, Criteria1:=Item
           
            Range("A" & erow & ":" & "Y" & erow).SpecialCells(xlCellTypeVisible).Copy
            Sheets(x).Range("A" & erow & ":" & "Y" & erow).PasteSpecial Paste:=xlPasteAll
            Application.CutCopyMode = False
           
            x = x + 1
        Next Item
   
        GoTo LINE99
    End If
   
   
    'Filter a single item in column since J3 is blank and there is only one item in column B to filter
    If annoying = 1 Then
   
        Sheets.Add After:=ActiveSheet
        Sheets("Sheet1").Select
       
        Item = Range("B2").Value
        .UsedRange.AutoFilter field:=2, Criteria1:=Item
    End If

    erow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1

    Range("A1:B" & erow).SpecialCells(xlCellTypeVisible).Copy
    Sheets(2).Range("A1:B" & erow).PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

LINE99:

    If .AutoFilterMode Then .UsedRange.AutoFilter

End With

End Sub
 
Upvote 0
Okay, try this:
VBA Code:
Sub unnamed_Sub2()

Sheets("Data").Select

Dim erow As Long
erow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1

Range("J1:J" & erow).Copy
Range("Z1:Z" & erow).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False

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

Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant
Dim hamburger As Double, x As Double

Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")

With ActiveSheet

    If Not .AutoFilterMode Then .UsedRange.AutoFilter
    If .Cells.AutoFilter Then .Cells.AutoFilter
      
    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
  
  
    If hamburger = 2 Then
  
        For i = 1 To UBound(Items, 1)
            Sheets.Add After:=Sheets(i)
        Next i
      
        Sheets("Data").Select
  
        x = 2
        For Each Item In ArrayDictionaryofItems.keys
  
            Sheets("Data").UsedRange.AutoFilter field:=10, Criteria1:=Item
          
            Range("A" & erow & ":" & "Y" & erow).SpecialCells(xlCellTypeVisible).Copy
            Sheets(x).Range("A" & erow & ":" & "Y" & erow).PasteSpecial Paste:=xlPasteAll
            Application.CutCopyMode = False
          
            x = x + 1
        Next Item
  
        GoTo LINE99
    End If
  
  
    'Filter a single item in column since J3 is blank and there is only one item in column B to filter
    If annoying = 1 Then
  
        Sheets.Add After:=ActiveSheet
        Sheets("Sheet1").Select
      
        Item = Range("B2").Value
        .UsedRange.AutoFilter field:=2, Criteria1:=Item
    End If

    erow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1

    Range("A1:B" & erow).SpecialCells(xlCellTypeVisible).Copy
    Sheets(2).Range("A1:B" & erow).PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

LINE99:

    If .AutoFilterMode Then .UsedRange.AutoFilter

End With

End Sub
sorry for the delay, on this row:

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

I got this error: Run-time error 1004: No cells were found
 
Upvote 0
and see if you see any solutions i could add or remove or alter to get this to run at a reasonable speed?
Hello, as it may depends on the source worksheet design so just link a workbook on a files host website like Dropbox​
with a good enough elaboration with details without nothing to guess …​
 
Upvote 0
sorry for the delay, on this row:

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

I got this error: Run-time error 1004: No cells were found
That means that, with all of the filters applied, it can happen that there is no rows to transfer. ("Due to the specific sequence of filters applied, the For Loop needs to be terminated earlier than expected.")

So since I know know that's possible (but also to guard against not ignoring any real errors),

VBA Code:
    If hamburger = 2 Then
  
        For i = 1 To UBound(Items, 1)
            Sheets.Add After:=Sheets(i)
        Next i
      
        Sheets("Data").Select
  
        x = 2
        For Each Item In ArrayDictionaryofItems.keys
  
            Sheets("Data").UsedRange.AutoFilter field:=10, Criteria1:=Item
            On Error GoTo LINE99ABC 'New line of code.
            Range("A" & erow & ":" & "Y" & erow).SpecialCells(xlCellTypeVisible).Copy
            Sheets(x).Range("A" & erow & ":" & "Y" & erow).PasteSpecial Paste:=xlPasteAll
            Application.CutCopyMode = False
          
            x = x + 1
        Next Item
  
        GoTo LINE99
    End If

And then, by label LINE99,
VBA Code:
LINE99:

    If .AutoFilterMode Then .UsedRange.AutoFilter

End With

LINE99ABC:'New line of code.
If Err.Description = "No cells were found." Then'New line of code.
    GoTo LINE99'New line of code.
Else'New line of code.
    Msgbox "Something went wrong.",vbCritical,"Error"'New line of code.
End If'New line of code.

End Sub
 
Upvote 0
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.
1632756271149.png
 
Upvote 0

Forum statistics

Threads
1,213,506
Messages
6,114,027
Members
448,543
Latest member
MartinLarkin

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
Back
Top