Hello Folks!
So I have this wonderful file that organizes project process by state / company, and one of the macros I run that I had assistance putting together a while back inserts calculated subtotal rows on every individual State's worksheet. The only problem is that it takes 12 minutes to run. Am I just stuck due to the large number of worksheets in this file? Anything at all I can do to optimize? All suggestions welcome.
So I have this wonderful file that organizes project process by state / company, and one of the macros I run that I had assistance putting together a while back inserts calculated subtotal rows on every individual State's worksheet. The only problem is that it takes 12 minutes to run. Am I just stuck due to the large number of worksheets in this file? Anything at all I can do to optimize? All suggestions welcome.
Code:
Option Explicit
Sub NEW_Insert_Sub_Totals_And_Sub_Averages()
UserForm1.Show
Dim ws As Variant
Dim LR As Long, LR1 As Long, LC As Long
Dim r As Range
Dim myRow As Long, Start As Long, lLoop As Long
Dim rFoundCell As Range
Dim xlCalc As XlCalculation
On Error GoTo ExitPoint
With Application
xlCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
Start = 4
For Each ws In Array("AL", "AZ", "CA", "CO", "FL", "GA", "ID", "IN", "KY", "ME", "MI", "MN", "MS", "NH", "NY", "OH", "OK", "PA", "SC", "TN", "VA", "VT", "WA", "WI", "XX", "Prior AL", "Prior AZ", "Prior CA", "Prior CO", "Prior FL", "Prior GA", "Prior ID", "Prior IN", "Prior KY", "Prior ME", "Prior MI", "Prior MN", "Prior MS", "Prior NH", "Prior NY", "Prior OH", "Prior OK", "Prior PA", "Prior SC", "Prior TN", "Prior VA", "Prior VT", "Prior WA", "Prior WI", "Prior XX")
Set ws = Sheets(ws)
With ws
.Activate
.Range("A4:BF500").Select
Selection.Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(12, 13, 14, 20, 21, 23, 24 _
, 25, 26, 27, 28, 29, 30, 31, 32), Replace:=True, PageBreaks:=False, SummaryBelowData:= _
True
myRow = .Columns("H").Find(What:="Grand*", LookIn:=xlValues, LookAt:=xlPart).Row
.Range("A" & myRow).EntireRow.Delete
With .Columns(8)
Set rFoundCell = .Cells(1, 1)
For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "*Total*")
Set rFoundCell = .Find(What:="*Total*", After:=rFoundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
ws.Cells(rFoundCell.Row, "BE").Formula = "=SubTotal(1,BE" & Start & ":BE" & rFoundCell.Row - 1 & ")"
Start = rFoundCell.Row + 1
Next lLoop
End With
Start = 4
ws.Range("A4").Select
End With
Next ws
Call NEW_Reset_Formatting
ExitPoint:
With Application
.Calculation = xlCalc
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
Unload UserForm1
Sheets("AL").Select
Range("K4").Select
Sheets("AZ").Select
Range("K4").Select
Sheets("CA").Select
Range("K4").Select
Sheets("CO").Select
Range("K4").Select
Sheets("FL").Select
Range("K4").Select
Sheets("GA").Select
Range("K4").Select
Sheets("ID").Select
Range("K4").Select
Sheets("IN").Select
Range("K4").Select
Sheets("KY").Select
Range("K4").Select
Sheets("ME").Select
Range("K4").Select
Sheets("MI").Select
Range("K4").Select
Sheets("MN").Select
Range("K4").Select
Sheets("MS").Select
Range("K4").Select
Sheets("NH").Select
Range("K4").Select
Sheets("NY").Select
Range("K4").Select
Sheets("OH").Select
Range("K4").Select
Sheets("OK").Select
Range("K4").Select
Sheets("PA").Select
Range("K4").Select
Sheets("SC").Select
Range("K4").Select
Sheets("TN").Select
Range("K4").Select
Sheets("VA").Select
Range("K4").Select
Sheets("VT").Select
Range("K4").Select
Sheets("WA").Select
Range("K4").Select
Sheets("WI").Select
Range("K4").Select
Sheets("XX").Select
Range("K4").Select
Call DeleteRows520OnwardforEachStateToManageFileSize
Sheets("Control Panel").Select
End Sub