Speed Up Macro: Populating tabs based on a variable

[dnicholsby]

Hello,

I have a spreadsheet that puts a stock into a specific tab depending on its industry. The trouble I am having is that I sometimes have 2000 stocks this has to cycle through and it takes a significant amount of time. If anyone can think of a way to speed it up I would appreciate it. Code is:

'This section clears the data from the Sector sheetsDim ws As Worksheet
For Each ws In Sheets(Array("Consumer Discretionary", "Consumer Staples", "Energy", "Banks", "Financials excl Banks", "Healthcare", "Industrials", "IT", "Materials", "Real Estate", "Telecoms", "Utilities"))


ws.Activate
range("A16").ClearContents
range("A17").Select
range(Selection, Selection.End(xlDown).End(xlToRight)).ClearContents
Next ws


'This creates a named range [FullStockList] for all stocks in the Stage 1 tab
Sheets("Stage 1").Select
Sheets("Stage 1").range("B7:B" & range("B7").End(xlDown).Row).Name = "FullStockList"


'This allocates each stock into its sector tab
Dim i As Variant


For Each i In [FullStockList]
i.Offset(0, 5).Select


If i.Offset(0, 5) = "Consumer Discretionary" Then
i.Copy
    Worksheets("Consumer Discretionary").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Consumer Staples" Then
    i.Copy
    Worksheets("Consumer Staples").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Energy" Then
    i.Copy
    Worksheets("Energy").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Financials" And i.Offset(0, 6) = "Banks" Then
    i.Copy
    Worksheets("Banks").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Financials" Then
    i.Copy
    Worksheets("Financials excl Banks").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Health Care" Then
    i.Copy
    Worksheets("Healthcare").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Industrials" Then
    i.Copy
    Worksheets("Industrials").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Information Technology" Then
    i.Copy
    Worksheets("IT").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Materials" Then
    i.Copy
    Worksheets("Materials").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Real Estate" Then
    i.Copy
    Worksheets("Real Estate").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Telecommunication Services" Then
    i.Copy
    Worksheets("Telecoms").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    ElseIf i.Offset(0, 5) = "Utilities" Then
    i.Copy
    Worksheets("Utilities").range("a9999").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
End If
Next i


Application.ScreenUpdating = True

 

[dnicholsby]

No errors in the code this time but nothing happened!

 

[JackDanIce]

Just tried to create a dummy copy of your workbook, did not name a range FormulasCD and the following works, apart from the FormulasCD part (commented out during testing, in blue):

Sub Macro1()

    Dim wks     As Worksheet
    Dim LR      As Long
    Dim LC      As Long
    Dim x       As Long
    Dim dic     As Object
    Dim var     As Variant
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
        
    For Each wks In Sheets(Array("Consumer Discretionary", "Consumer Staples", "Energy", "Banks", "Financials excl Banks", _
        "Healthcare", "Industrials", "IT", "Materials", "Real Estate", "Telecoms", "Utilities"))
        With wks
            LC = .Cells(17, .Columns.Count).End(xlToLeft).Column
            LR = .Cells(.Rows.Count, 1).End(xlUp).row
            With .Cells(16, 1)
                .ClearContents
                .Offset(1).Resize(LR, LC).ClearContents
            End With
        End With
    Next wks
    
    With Sheets("Stage 1")
        LR = .Cells(.Rows.Count, 2).End(xlUp).row
        
        For x = 7 To LR
            With .Cells(0 + x, 2)
                If Trim$(.Offset(, 5).Value) = "Financials" Then
                    
                    If Trim$(.Offset(, 6).Value) = "Banks" Then
                        dic(.Offset(, 6).Value) = Trim$(.Value)
                    Else
                        dic(.Offset(, 5).Value) = Trim$(.Value & "excl Banks")
                    End If
                Else
                    dic(.Offset(, 5).Value) = Trim$(.Value)
                End If
            End With
        Next x
    End With
    
    For Each var In dic
        On Error Resume Next
        Set wks = Sheets(var)
        On Error GoTo 0
        If Not wks Is Nothing Then
            With wks
                LR = .Cells(.Rows.Count, 1).End(xlUp).row
                .Cells(LR + 1, 1) = dic(var)
                .Range("FormulasCD").Copy
                .Cells(16, 2).PasteSpecial xlPasteFormulas
                Application.CutCopyMode = False
                .Select
                Application.Goto .Cells(16, 1), True
            End With
        Set wks = Nothing
        End If
    Next var
        
    Application.ScreenUpdating = True
    
    Set dic = Nothing
    
End Sub

I can see data correctly moving to the relevant sheets - maybe check the cell values match the sheet names exactly (i.e. no hidden characters like spaces)