How to optimize VBA code to run faster [closed] - excel

Question

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 9 years ago.
Improve this 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

Answer 1

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