Ok, I tried turning everything off as suggested, and it did run a bit faster, but I am still having problems when running it using a bigger set of data.
FYI: On the lower left of the screen it says "connecting to datasource" for a long period of time, not sure why (I never saw it before I added subtotals to the equation...). The data in the supporting worksheets only need to be updated long BEFORE the subtotals are inserted, so if there is a way to turn that off please let me know.
I am copying my code below. PLEASE be kind, this is my very first VBA project of any kind (I'm halfway thru VBA for Dummies) and the last time I was really good at Excel was in the 80's. Point out any dumb things I can fix, but pls be specific and don't assume I know anything.
The part that appears to be broken (tho I've included everything) is Sub AddSubtotals()
----------------
Sub Start()
Application.Cursor = xlWait
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets("Working").Visible = True
Sheets("Projected Costs").Unprotect
ActiveWindow.FreezePanes = False
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = off
End If
Rows("14:16").EntireRow.Hidden = False
End Sub
Sub Everything()
Worksheets("Cost Codes").Select
Range("A1").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Worksheets("Projected Costs").Select
Application.Run "Start"
ActiveWorkbook.RefreshAll
'don't need to remove subtotals for Change Job, _
fix this after other issues are resolved.
Application.Run "RemoveSubtotals"
Application.Run "CopyCostCodes"
Application.Run "FindDuplicates"
Application.Run "TransferCodes"
Application.Run "FillFormulas"
Application.Run "SortAll"
Application.Run "KillBlanks"
Application.Run "UnlockInputColumns"
Application.Run "MakeNames1"
Application.Run "AddSubtotals"
Application.Run "FormatTotalRows"
Application.Run "MakeNames2"
Application.Run "Finish"
End Sub
Sub CopyCostcodes()
Sheets("Working").Cells.Clear
Sheets("Cost Codes").Select
Range("B2").Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Pastes 9 times
Sheets("Working").Select
Range("a1").Select
ActiveSheet.Paste
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Selection.Copy
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending
Columns("A:A").Insert Shift:=xlToRight
Columns("A:A").Insert Shift:=xlToRight
Range("C1").End(xlDown).Offset(0, -1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Name = "AreaToFill"
Range("b1") = 1
Range("b2") = 2
Range("b3") = 3
Range("b4") = 4
Range("b5") = 5
Range("b6") = 6
Range("b7") = 7
Range("b8") = 8
Range("b9") = 9
Range("B1:B9").AutoFill Destination:=Range("AreaToFill"), Type:=xlFillCopy
End Sub
Sub FindDuplicates()
Sheets("Projected Costs").Select
Range("C15").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Working").Select
Range("H1").Select
ActiveSheet.Paste
Range("G1").FormulaR1C1 = "=MATCH(RC[-4],C[1],0)"
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Offset(0, 4).FillDown
ActiveSheet.Calculate
On Error GoTo Error_Exception
Selection.SpecialCells(xlCellTypeFormulas, 16).EntireRow.Copy
Error_Exception:
End Sub
Sub TransferCodes()
Sheets("Projected Costs").Select
Rows("16").Select
Selection.Insert Shift:=xlDown
If Range("B16") < 1 Then
Rows("16:16").Select
Selection.Delete Shift:=xlUp
End If
End Sub
Sub FillFormulas()
Range("E15").Select
Range(Selection, Selection.End(xlDown)).Select
NUMROWS = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(NUMROWS - 1, numColumns + 27).Select
Selection.FillDown
Selection.Resize(NUMROWS - 1, numColumns + 1).Offset(0, 29).Select
Selection.FillDown
Selection.Resize(NUMROWS - 1, numColumns + 3).Offset(0, 3).Select
Selection.FillDown
End Sub
Sub KillBlanks()
On Error GoTo ErrorHandler:
Range("AI15").Select
Range(Selection, Selection.End(xlDown)).Select
NUMROWS = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(NUMROWS - 1, numColumns + 0).Offset(0, 1). _
SpecialCells(xlCellTypeBlanks).Value = 0
Selection.Resize(NUMROWS - 1, numColumns + 0).Offset(0, -2). _
SpecialCells(xlCellTypeBlanks).Value = 0
ErrorHandler:
Columns("AJ:AJ").NumberFormat = "#,##0.00_);[Red](#,##0.00);"" - """
Columns("Ag:Ag").NumberFormat = "#,##0.00_);[Red](#,##0.00);"" - """
End Sub
Sub SortAll()
Range("D15").Select
Range(Selection, Selection.End(xlDown)).EntireRow.Select
Selection.Sort Key1:=Range("C15"), Order1:=xlAscending, Key2:=Range("B15" _
), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal
End Sub
Sub MakeNames1()
Range("b17").Select
Range(Selection, Selection.End(xlDown)).Select
ThisWorkbook.Names.Add Name:="COLE", _
RefersTo:="=" & Selection.Address()
Range("AL17").Select
Range(Selection, Selection.End(xlDown)).Select
NUMROWS = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(NUMROWS - 1, numColumns + 0).Select
ThisWorkbook.Names.Add Name:="PROJ", _
RefersTo:="=" & Selection.Address()
End Sub
Sub MakeNames2()
Range("D17").Select
Selection.End(xlDown).Select
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, -1).Range("A1").Select
ThisWorkbook.Names.Add Name:="TPC", _
RefersTo:="=" & Selection.Address()
ActiveCell.Offset(0, -23).Range("A1").Select
ThisWorkbook.Names.Add Name:="OB", _
RefersTo:="=" & Selection.Address()
End Sub
Sub RemoveSubtotals()
Range("D17").Select
Range(Selection, Selection.End(xlDown)).EntireRow.Select
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Selection.RemoveSubtotal
'trying leaving these off...
Application.EnableEvents = True
'Application.DisplayAlerts = True
'Application.ScreenUpdating = True
'Application.Calculation = xlCalculationAutomatic
'why is this here, check later
Range("C17").Select
Selection.CurrentRegion.Select
Selection.Sort Key1:=ActiveCell.Offset(-2, 2).Range("A1"), Order1:= _
xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub
Sub AddSubtotals()
Application.DisplayAlerts = False 'had to add this to make sure they don't choose wrong thing and screw up macro - eventually need to figure out why it pops up in the first place
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("B16:Ao16").Select
Range(Selection, Selection.End(xlDown)).Select
'turning off events because someone suggested it on Mr. Excel, I have no idea if this is what they meant exactly, or what it does, just trying anything at this point...
Application.EnableEvents = False
'this is the part I stole form the macro recorder... don't know how to do it otherwise, maybe a better way
Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38), Replace:=True, _
PageBreaks:=False, SummaryBelowData:=True
Application.EnableEvents = True
'fixes filter for subtotal lines
Range("d17").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Offset(0, 36).FillDown
Range("AN15", "AN17").FillDown
End Sub
Sub FormatTotalRows()
Range("C17").Select
Selection.CurrentRegion.Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Total" Then
Rows(rCell.Row).Interior.ColorIndex = 36
Rows(rCell.Row).Locked = True
End If
If Right(rCell.Value, 11) = "Grand Total" Then
Rows(rCell.Row).Interior.ColorIndex = 44
End If
Next
End Sub
Sub Refresh()
Application.Run "Everything"
End Sub
Sub Finish()
Sheets("Working").Visible = False
Rows("14:16").EntireRow.Hidden = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'trying to delete, see if works
Worksheets("Projected Costs").Unprotect
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True
Application.Cursor = xlDefault
Range("c1").Select
End Sub
-----------------------------
I apologize for posting something so long, but since I may have screwed up anywhere along the way, I thought it might matter. The part where it seems to be hanging is the module Add Subtotals()