How to optimize VBA code to run faster

Question

I need someone to save me on this one. I'm not a developer; I'm a QA. However, I've been tasked with creating a script that will take the mass data from one xlsx and creating new xlsx documents based on salesman, customer, and branch location. I have the code working, but it will take days for it to run if the computer it is running on does not run out of memory. I will post the code I have below. Is there any way to optimize it in order to run faster? We need it by Friday morning. Let me reiterate, I'm a QA. If you say do this or do that, I have no idea what you are talking about. I literally need "replace this with this". You guys have been awesome in you help so far, and I can't thank you enough. I don't know why you do what you do, but thank you for doing it.

Option Explicit

' get a named worksheet from specified workbook, creating it if required
Public Function GetSheet(ByVal Name As String, ByVal Book As Workbook, Optional ByVal Ignore As Boolean = False) As Worksheet
Dim Sheet As Worksheet
Dim Key As String
Dim Result As Worksheet: Set Result = Nothing

    Key = UCase(Name)

    ' loop over all the worksheets
    For Each Sheet In Book.Worksheets
        ' break out of the loop if the sheet is found
        If UCase(Sheet.Name) = Key Then
            Set Result = Sheet
            Exit For
        End If
    Next Sheet

    ' if the sheet isn't found..
    If Result Is Nothing Then
        If Ignore = False Then
            If Not GetSheet("Sheet1", Book, True) Is Nothing Then
                ' rename sheet1
                Set Result = Book.Worksheets("Sheet1")
                Result.Name = Name
            End If
        Else
            ' create a new sheet
            Set Result = Book.Worksheets.Add
            Result.Name = Name
        End If
        Result.Cells(1, 1) = "Rank"
        Result.Cells(1, 2) = "Customer Segment"
        Result.Cells(1, 3) = "Salesrep Name"
        Result.Cells(1, 4) = "Main_Customer_NK"
        Result.Cells(1, 5) = "Customer"
        Result.Cells(1, 6) = "FY13 Sales"
        Result.Cells(1, 7) = "FY13 Inv Cost GP$"
        Result.Cells(1, 8) = "FY13 Inv Cost GP%"
        Result.Cells(1, 9) = "Sales Growth"
        Result.Cells(1, 10) = "GP Point Change"
        Result.Cells(1, 11) = "Sales % Increase"
        Result.Cells(1, 12) = "Budgeted Total Sales"
        Result.Cells(1, 13) = "Budget GP%"
        Result.Cells(1, 14) = "Budget GP$"
        Result.Cells(1, 15) = "Target Account"
        Result.Cells(1, 16) = "Estimated Total Purchases"
        Result.Cells(1, 17) = "Estimated Sales Calls Monthly"
        Result.Cells(1, 18) = "Notes"
        Result.Cells(1, 19) = "Reference 1"
        Result.Cells(1, 20) = "Reference 2"

        'and the rest....
    End If

    Set GetSheet = Result

End Function


Sub Main()
Dim Source As Worksheet
Dim Location As Workbook
Dim Sales As Worksheet
Dim LocationKey As String
Dim SalesKey As String
Dim Index As Variant
Dim Map As Object: Set Map = CreateObject("Scripting.Dictionary")
Dim Row As Long
Dim InsertPos As Long

    Set Source = ThisWorkbook.ActiveSheet

    Row = 2 ' Skip header row

    Do
        ' break out of the loop - assumes that the first empty row signifies the end
        If Source.Cells(Row, 1).Value2 = "" Then
            Exit Do
        End If

        LocationKey = Source.Cells(Row, 3).Value2

        ' look at the location, and find the workbook, creating it if required
        If Map.Exists(LocationKey) Then
            Set Location = Map(LocationKey)
        Else
            Set Location = Application.Workbooks.Add(xlWBATWorksheet)
            Map.Add LocationKey, Location
        End If

        SalesKey = Source.Cells(Row, 5).Value2

        ' get the sheet for the salesperson
        Set Sales = GetSheet(SalesKey, Location)

        ' Get the location to enter the data
        InsertPos = Sales.Range("A1").End(xlDown).Row + 1



        'check to see if it's a new sheet, and adjust
        If InsertPos = 1048577 Then
        'Stop
            InsertPos = 2
            'change to 65537 is using excel 2003 or before
            Macro1
        End If

        ' populate said row with the data from the source
        Sales.Cells(InsertPos, 1).Value2 = Source.Cells(Row, 1)
        Sales.Cells(InsertPos, 2).Value2 = Source.Cells(Row, 2)
        Sales.Cells(InsertPos, 3).Value2 = Source.Cells(Row, 5)
        Sales.Cells(InsertPos, 4).Value2 = Source.Cells(Row, 6)
        Sales.Cells(InsertPos, 5).Value2 = Source.Cells(Row, 7)
        Sales.Cells(InsertPos, 6).Value2 = Source.Cells(Row, 8)
        Sales.Cells(InsertPos, 7).Value2 = Source.Cells(Row, 9)
        Sales.Cells(InsertPos, 8).Value2 = Source.Cells(Row, 10)
        Sales.Cells(InsertPos, 9).Value2 = Source.Cells(Row, 11)
        Sales.Cells(InsertPos, 10).Value2 = Source.Cells(Row, 12)
        Sales.Cells(InsertPos, 11).Value2 = Source.Cells(Row, 13)
        Sales.Cells(InsertPos, 12).Value2 = Source.Cells(Row, 14)
        Sales.Cells(InsertPos, 13).Value2 = Source.Cells(Row, 15)
        Sales.Cells(InsertPos, 14).Value2 = Source.Cells(Row, 16)
        Sales.Cells(InsertPos, 19).Value2 = Source.Cells(Row, 17)
        Sales.Cells(InsertPos, 20).Value2 = Source.Cells(Row, 18)
        Sales.Range("L" & InsertPos).Formula = "=(F2*K2)+F2"
        Sales.Range("N" & InsertPos).Formula = "=(M2+H2)*L2"

        'increment the loop



        'Range("H" & InsertPos).Activate
        'If Range("F" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (100 * Range("G" & InsertPos) / Range("F" & InsertPos))

        'Range("I" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("F" & InsertPos) / Range("S" & InsertPos) - 1)

        'Range("J" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("T" & InsertPos) / Range("S" & InsertPos))

        Row = Row + 1

        Macro2 'runs on each cell
    Loop


    ' loop over the resulting workbooks and save them - using the location name as file name
    For Each Index In Map.Keys

          Set Location = Map(Index)

        Location.SaveAs Filename:=Index
    Next Index

End Sub

Sub Macro1()
'
' Macro1 Macro
'

'
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("F:G").Select
    Selection.NumberFormat = "$#,##0.00"
    ActiveWindow.SmallScroll ToRight:=3
    Columns("H:J").Select
    Selection.NumberFormat = "0.00%"
    Selection.NumberFormat = "0.0%"
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    Range("K:K,M:M").Select
    Range("M1").Activate
    Selection.NumberFormat = "0.0%"
    Range("N:N,L:L").Select
    Range("L1").Activate
    Selection.NumberFormat = "$#,##0.00"
    ActiveWindow.SmallScroll ToRight:=5
    Columns("S:T").Select
    Selection.EntireColumn.Hidden = True
    ActiveWindow.SmallScroll ToRight:=-4
    Range("K:K,M:M").Select
    Range("M1").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Cells.Select
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Range("L9").Activate
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Cells.EntireColumn.AutoFit
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

End Sub

Sub Macro2()
'
' Macro2 Macro
'

'
    Cells.EntireColumn.AutoFit
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        14, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Welcome to StackOverflow. Your question is entirely too vague and broad in scope ("Here are a couple hundred lines of code. Can you make it run faster? I need it by Friday.". I'm sorry, but it's off-topic here. If you "need it by Friday", you should have either started working on it sooner or you should be scrambling to find a contractor you can hire on an emergency basis to get it done for you. We're not a code writing service. :-) You might want to review the [ask] page that you agreed you understood when creating your account here before posting future questions. Good luck. — Ken White, Sep 05 '13 at 02:54
Please see my other posts. I have been working on this and tweaking this the best I know before you derive general assumptions. My original post was made just an hour after receiving the task. You would see that if you clicked on my previous posts. I contribute regularly in QA forums where developers go to ask questions on testing based development, and I come here when I need advice on testing development. Never have I been tasked with development before, so I thought I would begin posting on this issue. Thank you for the orientation. — Jack Prible, Sep 05 '13 at 03:03
I see three previous questions, 1 of which was closed, one of which has no answers, and one that was downvoted once with no answers. I'm not sure what I'm supposed to take away from that info. I judge this question on its own merits as I described before (too broad and vague, with a deadline that isn't our concern). I'm sorry it's urgent for you, but it isn't for us, I'm afraid; there are 1 million plus users here whose questions are of equal priority. If you need urgent help, you need to hire someone who can devote 100% of their attention to your issue. Sorry. Glad you're helping in QA. :-) — Ken White, Sep 05 '13 at 03:11
I only wish I had the authority to say, "You need to hire some outside help for that." Unfortunately, they've told me that they've hired some outside help to QA it for me. It's like telling a developer they've hired someone else to develop the code you've already written as a BA even though that's not your job. — Jack Prible, Sep 05 '13 at 03:34
Turn off ScreenUpdating and set calculation to manual. That alone should give you s good boost. Beyond that, change your cell-by-cell data transfer to instead use arrays to write data in single operation. — Tim Williams, Sep 05 '13 at 04:01
I agree with @TimWilliams. Turning off ScreenUpdating is probably the first thing you should do and will result in a significantly lower execution time. It's simple enough for a non-coder as well. Just find the first function that runs and turn it off at the start, then find the last function and turn it back on at the end. Getting rid of the one-cell-at-a-time changes is the next biggest thing, but that requires significantly more programming skill. It is also, unfortunately, beyond the scope of SO to carry out as an "answer". — techturtle, Sep 05 '13 at 04:17
Thanks, Tim and Turtle. THat's easy enough. I will try this. — Jack Prible, Sep 05 '13 at 04:18
How do i upvote or add to your reputations for those comments? — Jack Prible, Sep 05 '13 at 04:30

score 2 · Accepted Answer · answered Sep 05 '13 at 07:51

Just got rid of some select statements, added some loops, and turned off screen updating and set calculation to manual while executing. I have added some comments here and there, check them out too. See if that helps

Option Explicit

Sub Main()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    Dim Source As Worksheet
    Dim Location As Workbook
    Dim Sales As Worksheet
    Dim LocationKey As String
    Dim SalesKey As String
    Dim Index As Variant
    Dim Map As Object: Set Map = CreateObject("Scripting.Dictionary")
    Dim Row As Long
    Dim InsertPos As Long

    Set Source = ThisWorkbook.ActiveSheet

    Row = 2 ' Skip header row

    Do
        ' break out of the loop - assumes that the first empty row signifies the end
        If Source.Cells(Row, 1).Value2 = "" Then
            Exit Do
        End If

        LocationKey = Source.Cells(Row, 3).Value2

        ' look at the location, and find the workbook, creating it if required
        If Map.Exists(LocationKey) Then
            Set Location = Map(LocationKey)
        Else
            Set Location = Application.Workbooks.Add(xlWBATWorksheet)
            Map.Add LocationKey, Location
        End If

        SalesKey = Source.Cells(Row, 5).Value2

        ' get the sheet for the salesperson
        Set Sales = GetSheet(SalesKey, Location)

        ' Get the location to enter the data
        InsertPos = Sales.Range("A1").End(xlDown).Row + 1

        'check to see if it's a new sheet, and adjust
        If InsertPos = 1048577 Then
        'Stop
            InsertPos = 2
            'change to 65537 is using excel 2003 or before
            Macro1
        End If

        ' populate said row with the data from the source
        Dim i As Long
        For i = 1 To 2
            Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i)
        Next i
        For i = 3 To 14
            Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i + 2)
        Next i
        For i = 19 To 20
            Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i - 2)
        Next i
        Sales.Range("L" & InsertPos).Formula = "=(F2*K2)+F2"
        Sales.Range("N" & InsertPos).Formula = "=(M2+H2)*L2"


        'increment the loop
        'Range("H" & InsertPos).Activate
        'If Range("F" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (100 * Range("G" & InsertPos) / Range("F" & InsertPos))

        'Range("I" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("F" & InsertPos) / Range("S" & InsertPos) - 1)

        'Range("J" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("T" & InsertPos) / Range("S" & InsertPos))

        Row = Row + 1

        Macro2 'runs on each cell
    Loop


    ' loop over the resulting workbooks and save them - using the location name as file name
    For Each Index In Map.Keys
        Set Location = Map(Index)
        Location.SaveAs Filename:=Index
    Next Index

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub


' get a named worksheet from specified workbook, creating it if required
Public Function GetSheet(ByVal Name As String, ByVal Book As Workbook, Optional ByVal Ignore As Boolean = False) As Worksheet
    Dim Sheet As Worksheet
    Dim Key As String
    Dim Result As Worksheet: Set Result = Nothing

    Key = UCase(Name)

    ' loop over all the worksheets
    For Each Sheet In Book.Worksheets
        ' break out of the loop if the sheet is found
        If UCase(Sheet.Name) = Key Then
            Set Result = Sheet
            Exit For
        End If
    Next Sheet

    ' if the sheet isn't found..
    If Result Is Nothing Then
        If Ignore = False Then
            If Not GetSheet("Sheet1", Book, True) Is Nothing Then
                ' rename sheet1
                Set Result = Book.Worksheets("Sheet1")
                Result.Name = Name
            End If
        Else
            ' create a new sheet
            Set Result = Book.Worksheets.Add
            Result.Name = Name
        End If

        Dim arr
        arr = Array("Rank", "Customer Segment", "Salesrep Name", "Main_Customer_NK", "Customer", "FY13 Inv Cost GP$", "FY13 Inv Cost GP%", "Sales Growth", "GP Point Change", "Sales % Increase", _
                    "Budgeted Total Sales", "Budget GP%", "Budget GP$", "Target Account", "Estimated Total Purchases", "Estimated Sales Calls Monthly", "Notes", "Reference 1", "Reference 2")

        Dim i As Long
        For i = LBound(arr) To UBound(arr)
            Result.Cells(1, i + 1) = arr(i)
        Next i

        ' stick the rest in the arr variable and you dont need the below anymore
        'Result.Cells(1, 1) = "Rank"
        'Result.Cells(1, 2) = "Customer Segment"
        'Result.Cells(1, 3) = "Salesrep Name"
        'Result.Cells(1, 4) = "Main_Customer_NK"
        'Result.Cells(1, 5) = "Customer"
        'Result.Cells(1, 6) = "FY13 Sales"
        'Result.Cells(1, 7) = "FY13 Inv Cost GP$"
        'Result.Cells(1, 8) = "FY13 Inv Cost GP%"
        'Result.Cells(1, 9) = "Sales Growth"
        'Result.Cells(1, 10) = "GP Point Change"
        'Result.Cells(1, 11) = "Sales % Increase"
        'Result.Cells(1, 12) = "Budgeted Total Sales"
        'Result.Cells(1, 13) = "Budget GP%"
        'Result.Cells(1, 14) = "Budget GP$"
        'Result.Cells(1, 15) = "Target Account"
        'Result.Cells(1, 16) = "Estimated Total Purchases"
        'Result.Cells(1, 17) = "Estimated Sales Calls Monthly"
        'Result.Cells(1, 18) = "Notes"
        'Result.Cells(1, 19) = "Reference 1"
        'Result.Cells(1, 20) = "Reference 2"

        'and the rest....
    End If

    Set GetSheet = Result
End Function



Sub Macro1()
    ' avoid using Select
    Columns.AutoFit
    Columns("F:G").NumberFormat = "$#,##0.00"
    Columns("H:J").NumberFormat = "0.0%"
    Range("K:K,M:M").NumberFormat = "0.0%"
    Range("N:N,L:L").NumberFormat = "$#,##0.00"
    Columns("S:T").EntireColumn.Hidden = True
    With Range("K:K,M:M").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Range("L9").Activate
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Cells.EntireColumn.AutoFit
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

End Sub

Sub Macro2()

    Columns.AutoFit
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        14, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Mehow. Thank you! I have it running on three different machines right now, and it keeps bombing out due to the mapping. I'm going to guess this is because of how volatile this is, but I really appreciate your help. Every time I run it, I am able to capture 10 to 15 more useable spreadsheets. Once I get all 160 branches I'm good to go. I knew this would need an array, but I had no idea how to do one. Thank you thank you thank you so much! — Jack Prible, Sep 05 '13 at 12:58
@JackPrible youre welcome. I cannot fix anything else related to your problem as I am not physically there and I cant investigate it the way I normally do. The code is a *good starter* to speed up the process. If you are satisfied with the answer you can accept and upvote it. Good luck — , Sep 05 '13 at 13:05
Thanks, @Mehow! I've got it running on 800k lines right now, and it should be done in a few hours. The error it was running in to was just on 1 box. The other 2 boxes are running it just fine. I accepted the answer, but it looks like I don't have enough reputation to upvote it. You're a lifesaver, Mehow! — Jack Prible, Sep 05 '13 at 14:53
@JackPrible glad it works. Yea voting requires 20 rep I think. — , Sep 05 '13 at 14:57
@JackPrible : it may be that a lot of your issues are because you have too many workbooks open by the end of your run. You might try compiling only one workbook at a time. That does mean running through the dataset multiple times, but that overhead might be offset by a more stable process. — Tim Williams, Sep 05 '13 at 16:45
You guys rock. It just finished. 11.1 million cells separated, concatenated, subtotaled, and organized. Thank you so much!!!! — Jack Prible, Sep 05 '13 at 20:10
@Mehow How do i get the formulas back in there for L and N? They weren't created by the script, but they were before. — Jack Prible, Sep 05 '13 at 22:45
@JackPrible I haven't touched the L or N lines. But try debug.print `InsertPos` to see if it has a correct row number — , Sep 06 '13 at 07:03
@JackPrible as Tim suggested you could work with one workbook at a time which would not be a bad idea considering the amount of workbooks. Feel free to adopt [my other solution](http://stackoverflow.com/questions/17461935/vba-macro-to-mass-update-multiple-files-in-same-location/17470628#17470628) — , Sep 06 '13 at 07:04
Thanks! The missing key in my similar problem was Automatic vs Manual Calculation. — Payam, Mar 08 '15 at 21:23

How to optimize VBA code to run faster

1 Answers1