Hello all,
Below I've pasted some code for a macro that I've been using. The macro chugs quite slowly on my computer, and actually crashed my boss's computer.
The macro runs through a number of operations, like filling data into blank cells, deleting entries that meet certain criteria, and splitting the remaining data into different sheets.
I was wondering if there's any way I can optimize this code so it runs faster. When pasted into a Word document, the code is 7 pages long.
Thank you for any help!
Code
Function SheetExists(SheetName As String) As Boolean
' returns TRUE if the sheet exists in the active workbook
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If
NoSuchSheet:
End Function
Sub SalesCostOfSales()
'
' SalesCostOfSales Macro
' Macro created by Anthony Barrovecchio
'
Application.ScreenUpdating = False
ActiveSheet.Name = "Sheet1"
Application.DisplayAlerts = False
Worksheets("Blank").Delete
Application.DisplayAlerts = True
'Fills product codes in the blank cells'
lastrow = Range("G65536").End(xlUp).Row
For i = 6 To lastrow
If Range("C" & i).Value = "" Then
Range("C" & i - 1 & ":C" & i - 1).Copy Destination:=Range("C" & i)
End If
Next i
'Sorts by function code, then product code, then margin %'
Range("A1:G10000").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Key3:=Range("G2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
'Creates table for margin limits and names it'
Sheets.Add.Name = "Sheet2"
Sheets("Sheet2").Range("A1").Value = "Product Name"
Sheets("Sheet2").Range("B1").Value = "Margin Limit"
Sheets("Sheet2").Range("A2").Value = 103
Sheets("Sheet2").Range("B2").Value = 0.25
Sheets("Sheet2").Range("A3").Value = 108
Sheets("Sheet2").Range("B3").Value = 0.25
Sheets("Sheet2").Range("A4").Value = 116
Sheets("Sheet2").Range("B4").Value = 0.25
Sheets("Sheet2").Range("A1:B4").Select
ActiveWorkbook.Names.Add Name:="Table", RefersToR1C1:="=Sheet2!R1C1:R4C2"
ActiveWorkbook.Names.Add Name:="Table", RefersToR1C1:="=Sheet2!R1C1:R4C2"
'Gets rid of empty rows'
Sheets.Add.Name = "Totals"
Worksheets("Sheet1").Select
lastrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
Rows(lastrow & ":" & Rows.Count).Copy
Worksheets("Totals").Select
Range("A1").PasteSpecial xlPasteAll
Worksheets("Sheet1").Select
lastrow = Cells(Rows.Count, "A").End(xlUp).Row - 2
Rows(lastrow & ":" & Rows.Count).Delete Shift:=xlUp
'Deletes entries with acceptable margin %s'
Dim j As Long, x As Double, r As Range
Set r = Range("Table") 'The reference table with product in the first column and cutoff in the second
j = Cells(Rows.Count, 1).End(xlUp).Row 'last line to check
While j > 1 'loop through all but the first row, starting at bottom
x = IIf(Application.WorksheetFunction.IsError(Application.VLookup(Cells(j, 3), r, 2, 0)), 0.125, Application.VLookup(Cells(j, 3), r, 2, 0)) 'get cutoff value for this product code
If Cells(j, 7) > x Then Rows(j).Delete
j = j - 1
Wend
'Replaces names'
Cells.Replace What:="01 - Parts Domestic", Replacement:="01", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="07 - Parts - Export", Replacement:="7", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="21 - Parts - Export", Replacement:="21", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="31 - Maag Services", Replacement:="31", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="33 - Operational Services", Replacement:="33", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="34 - Training", Replacement:="34", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="36 - Field Installation", Replacement:="36", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="37 - Plant Services", Replacement:="37", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="55 - Cement Parts Sales - Domestic", Replacement:="55" _
, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
:=False, ReplaceFormat:=False
Cells.Replace What:="56 - Non-Cement Parts Sales - Int'L", Replacement:= _
"56", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="57 - Non-Cement Parts Sales - Dom", Replacement:="57" _
, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
:=False, ReplaceFormat:=False
Cells.Replace What:="75 - Component Sales - Domestic", Replacement:="75", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
Cells.Replace What:="76 - Component Sales - Int'l", Replacement:="76", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
Cells.Replace What:="96 - Compressor Sales - Domestic", Replacement:="96", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
Cells.Replace What:="97 - Compressor Sales - Int'l", Replacement:="97", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Splits data up by function code'
Dim rng As Range, StrtSht As String, WhtSht As String
StrtSht = ActiveSheet.Name
For Each rng In Range("A1:A" & Range("A65536").End(xlUp).Row)
WhtSht = rng.Value
If WhtSht = "21" Then WhtSht = "7"
If WhtSht = "34" Then WhtSht = "33"
If WhtSht = "36" Then WhtSht = "33"
If WhtSht = "37" Then WhtSht = "33"
If WhtSht = "56" Then WhtSht = "55"
If WhtSht = "57" Then WhtSht = "55"
If WhtSht = "76" Then WhtSht = "75"
If WhtSht = "97" Then WhtSht = "96"
If SheetExists(WhtSht) Then
Rows(rng.Row).Copy
Sheets(WhtSht).Select
Range("A" & Range("A65536").End(xlUp).Row + 1).PasteSpecial xlPasteAll
Sheets(StrtSht).Select
Else
Sheets.Add.Name = WhtSht
Sheets(StrtSht).Select
Rows(rng.Row).Copy
Sheets(WhtSht).Select
Range("A1").PasteSpecial xlPasteAll
Sheets(StrtSht).Select
End If
Next
'Re-names sheets'
Worksheets("7").Name = "7, 21"
Worksheets("33").Name = "33, 34, 36, 37"
Worksheets("55").Name = "55, 56, 57"
Worksheets("75").Name = "75, 76"
Worksheets("96").Name = "96, 97"
'Deletes extra sheets'
Application.DisplayAlerts = False
Worksheets("Sheet1").Delete
Worksheets("Sheet2").Delete
Application.DisplayAlerts = True
'Formats columns and cells, and adds headers'
Worksheets("Totals").Select
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual Subtotal"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual Subtotal"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Margin Subtotal"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Range("A1").Select
Worksheets("1").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Function Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Project Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual SUM"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual SUM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Margin"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Margin %"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
Worksheets("7, 21").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Function Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Project Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual SUM"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual SUM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Margin"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Margin %"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
Worksheets("31").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Function Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Project Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual SUM"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual SUM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Margin"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Margin %"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
Worksheets("33, 34, 36, 37").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Function Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Project Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual SUM"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual SUM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Margin"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Margin %"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
Worksheets("55, 56, 57").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Function Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Project Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual SUM"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual SUM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Margin"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Margin %"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
Worksheets("75, 76").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Function Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Project Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual SUM"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual SUM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Margin"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Margin %"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
Worksheets("96, 97").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Function Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Project Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Product Code"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Revenue Accrual SUM"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Cost Accrual SUM"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Margin"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Margin %"
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Display More