0

This demo will be scaled up to perform this operation on data ranges with 100's of rows, so I'm not sure how to make the runtime faster, and avoid selecting different sized ranges using the xlToRight if there was adjacent data. Attached is a view-only xlsm. spreadsheet

Sub Main_Loop()
' This script  references the number of unique items in the
' filter then loops the data extraction based on this value.
'
' Keyboard Shortcut: Ctrl+Shift+Z
'
' Nate_Ayers
Application.ScreenUpdating = False
Range("H1").Select
Dim i As Integer 'counter
Dim Loop_var As String
Loop_end = Range("A2").Value2 'Stop loop at end of unique items
For i = 1 To Loop_end
    Selection.Copy
    Range("A3").Select 'Helper cell location chosen where data wont overwrite the cell
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False 'Paste values only (avoids unique function)
    Application.CutCopyMode = False
    Selection.Copy
    Columns("C:C").AutoFilter
    ActiveSheet.Range("C:C").AutoFilter Field:=1, Criteria1:=Range("A3")
    
    'Data block grab:
    Range("C2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Application.CutCopyMode = False
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Range("A2").Select
    ActiveSheet.Paste
    Range("A2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Worksheets(ActiveSheet.Index).Select 'could have efficiency improvement
    Worksheets(ActiveSheet.Index).Name = Selection 'Name the sheet
    Range("A1").Select
    ActiveSheet.Paste
    Selection.Font.Bold = True
    Sheets("Demo").Select
    Range("A3").Select
    Selection.ClearContents
    Selection.AutoFilter
    Range("H1").Select
    ActiveCell.Offset(0, i).Select 'Reference next row to repeat operations
    Next i
Application.ScreenUpdating = True
End Sub
  • 1
    Do not use `.activate` and `.select` see [HERE](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). Try using what is there and clean up your code. If it is still moving too slow we can address next steps, but right now it is hard to see anything but the `.Select` issue. – Scott Craner Mar 09 '22 at 23:01
  • If I have commands that rely on my "selection" how do I incorporate those? – Bubbybristor Mar 09 '22 at 23:44
  • That is the point, read the link. There are very very few commands that require using select before. And none of the ones you are using. – Scott Craner Mar 09 '22 at 23:51

1 Answers1

1

It's hard to know what some of your subroutine is doing without seeing the underlying spreadsheet, and some of the variables don't seem to be referenced. But here are a few examples of how you might be able to speed things up. As already mentioned the main issue is the unnecessary use of copy and paste. This probably won't be a solution that works, but I hope it helps you on the way.

Sub Main_Loop()

Dim vCalc, vEvents As Variant
Dim ws, new_ws As Worksheet
Dim i As Integer 'counter

Application.ScreenUpdating = False
vCalc = Application.Calculation
Application.Calculation = xlCalculationManual
vEvents = Application.EnableEvents
Application.EnableEvents = False
Set ws = ActiveSheet

i = 1
While ws.Range("H" & i) <> ""
    ws.Range("A3").Value = ws.Range("H" & i).Value
    ws.Range("C:C").AutoFilter Field:=1, Criteria1:=Range("A3")
    
    Set new_ws = Sheets.Add(After:=ActiveSheet)
    ws.Range("C2").CurrentRegion.Copy
    new_ws.Range("A2").Paste
    new_ws.Name = new_ws.Range("A2").Value
    new_ws.Range("A1").Value = new_ws.Range("A2").Value
    new_ws.Range("A1").Font.Bold = True
    i=i+1
Wend
ws.Range("A3").ClearContents

Application.ScreenUpdating = True
Application.Calculation = vCalc
Application.EnableEvents = vEvents

End Sub
bn_ln
  • 1,648
  • 1
  • 6
  • 13