Speed Up Macro: Populating tabs based on a variable

D

dnicholsby

New Member
Joined
Jan 24, 2017
Messages
26
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:

Code: 
'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
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
You can get rid of Activates and Selects, and since you are copying cell values you can do direct cell value assignments instead of separate copy and paste statements which use the clipboard.

This shows the idea:
Code: 
    '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"))
        With ws
            .Range("A16").ClearContents
            .Range(.Range("A17"), .Range("A17").End(xlDown).End(xlToRight)).ClearContents
        End With
    Next ws
    
    
    'This creates a named range [FullStockList] for all stocks in the Stage 1 tab
    With Sheets("Stage 1")
        .Range("B7", .Range("B7").End(xlDown)).Name = "FullStockList"
    End With
    
    
    'This allocates each stock into its sector tab
    Dim i As Variant
    Dim destCell As Range
    
    For Each i In [FullStockList]
        
        If i.Offset(0, 5).Value = "Consumer Discretionary" Then
        
            Set destCell = Worksheets("Consumer Discretionary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            destCell.Value = i.Value
 
Upvote 0
Hi,

This should be a lot quicker for you...

Code: 
    Dim ws As Worksheet
    Dim FullStocklist As Variant
    Dim lRow As Long, i As Long


    Application.ScreenUpdating = False
    '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 an array named [FullStockList] for all stocks in the Stage 1 tab
    Sheets("Stage 1").Select
    FullStocklist = Sheets("Stage 1").Range("B7:G" & Range("B7").End(xlDown).Row)


    'This allocates each stock into its sector tab


    For i = LBound(FullStocklist) To UBound(FullStocklist)
        Select Case FullStocklist(i, 6)
        
            Case Is = "Consumer Discretionary"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Consumer Staples"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Energy"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
                    
            Case Is = "Banks"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Financials excl Banks"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Healthcare"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Industrials"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Information Technology"
                With Worksheets("IT")
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Materials"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Real Estate"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Telecoms"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
            
            Case Is = "Utilities"
                With Worksheets(FullStocklist(i, 6))
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    .Range("A" & lRow) = FullStocklist(i, 1)
                End With
    End Select
    Next i
    Application.ScreenUpdating = True

I hope this helps
 
Upvote 0
Thanks very much to both of you. I found John_w's solution to be slightly faster!

I have one more question...

After the stocks are filled I have a set of formulas in the next 40 columns. I have a code that copies it down:


Code: 
Worksheets("Consumer Discretionary").Activate
Worksheets("Consumer Discretionary").range("FormulasCD").Copy
range("A16").Select
Selection.End(xlDown).Offset(0, 1).Select
range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
range("A16").Select

Obviously there is one for each sector

Could i make it faster by changing it to or is the difference in speed negligible?

Code: 
Worksheets("Consumer Discretionary").range("FormulasCD").Copy
range("A16").Selection.End(xlDown).Offset(0, 1).Select
range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
range("A16").Select

Note the range("a16").select at the end is so it goes to the start of the sheet when the user looks through
 
Upvote 0
Untested but hopefully shorter code and includes for the question for formulas:
Code: 
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 .Offset(, 5).Value = "Financials" Then
                    If .Offset(, 6).Value = "Banks" Then
                        dic(.Offset(, 6)) = .Value
                    Else
                        dic(.Offset(, 5)) = .Value & "excl Banks"
                    End If
                Else
                    dic(.Offset(, 5)) = .Value
                End If
            End With
        Next x
    End With
    
    For Each var In dic
        Set wks = Sheets(var)
        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
    Next var
        
    Application.ScreenUpdating = True
    
    Set dic = Nothing
    
End Sub
 
Last edited:
Upvote 0
I made an edit to the code after I posted it initially, can you copy and use the code again, that line is no longer there
 
Upvote 0
For clarity, try:
Code: 
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 .Offset(, 5).Value = "Financials" Then
                    
                    If .Offset(, 6).Value = "Banks" Then
                        dic(.Offset(, 6)) = .Value
                    Else
                        dic(.Offset(, 5)) = .Value & "excl Banks"
                    End If
                Else
                    dic(.Offset(, 5)) = .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
    Next var
        
    Application.ScreenUpdating = True
    
    Set dic = Nothing
    
End Sub
 
Last edited:
Upvote 0
Nope! Next var produces an error "Next without For". Do you not need to define var?
 
Last edited:
Upvote 0
No forgot an End If, sorry! Try:
Code: 
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 .Offset(, 5).Value = "Financials" Then
                    
                    If .Offset(, 6).Value = "Banks" Then
                        dic(.Offset(, 6)) = .Value
                    Else
                        dic(.Offset(, 5)) = .Value & "excl Banks"
                    End If
                Else
                    dic(.Offset(, 5)) = .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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
Add a column w/ formula to copy / paste macro
Replies
5
Views
60
wknight7
W
A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
756
Joe4
Joe4
K
  • Question
Paste Data Below last row
Replies
3
Views
268
rlv01
R
B
  • Solved
vba code to give next Sunday date for pasted data
Replies
2
Views
210
bh24524
B
H
  • Solved
Macro to copy data based on specific criteria
Replies
6
Views
375
howard
H

Forum statistics

Threads
1,215,482
Messages
6,125,061
Members
449,206
Latest member
Healthydogs

Share this page

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