Solved: slow macro

I wrote the attached macro (with a lot of a lot of your help.....so thank you :) ). It is doing what I want it to do, but it takes over a minute for it to run when I run it on my real file which has over 4000 rows and it's a little over 1MB (in the test one with only a couple hundred rows it runs fast). I realize it's doing quite a bit, but I was wondering if there was a way to make the code more efficient.

workbook with code attached and code is below as well:

[VBA]
Sub MonthlyEnrollmentCount()
Dim numRecs As Integer

Rows("1:5").Delete Shift:=xlUp
numRecs = Cells(Rows.Count, "A").End(xlUp).Row - 1

'name sheets
ActiveSheet.Name = "Monthly Enrollment"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Sheet1").Name = "Counts"

'name ranges
ActiveWorkbook.Names.Add Name:="Tier", RefersToR1C1:= _
"=OFFSET('Monthly Enrollment'!R1C16,,,COUNTA('Monthly Enrollment'!C1))"
ActiveWorkbook.Names.Add Name:="Month", RefersToR1C1:= _
"=OFFSET('Monthly Enrollment'!R1C18,,,COUNTA('Monthly Enrollment'!C1))"
ActiveWorkbook.Names.Add Name:="BillingLine", RefersToR1C1:= _
"=OFFSET('Monthly Enrollment'!R1C13,,,COUNTA('Monthly Enrollment'!C1))"
ActiveWorkbook.Names.Add Name:="AmountDue", RefersToR1C1:= _
"=OFFSET('Monthly Enrollment'!R1C22,,,COUNTA('Monthly Enrollment'!C1))"
ActiveWorkbook.Names.Add Name:="Subscribers", RefersToR1C1:= _
"=OFFSET('Monthly Enrollment'!R1C10,,,COUNTA('Monthly Enrollment'!C1))"

Sheets("Monthly Enrollment").Select
Range("A2").Select
ActiveWindow.FreezePanes = True
Cells.EntireColumn.AutoFit

Range("W1").FormulaR1C1 = "Number of Lines"
Range("W2").Resize(numRecs).FormulaR1C1 = "=COUNTIF(Subscribers,RC[-13])"

Rows("1:1").AutoFilter

Sheets("Counts").Select
Range("B1").FormulaR1C1 = "EMP"
Range("C1").FormulaR1C1 = "EMP+DEP"
Range("D1").FormulaR1C1 = "EMP+FAMILY"
Range("E1").FormulaR1C1 = "TOTAL"
Range("F1").FormulaR1C1 = "EMP RATE"
Range("G1").FormulaR1C1 = "EMP+DEP RATE"
Range("H1").FormulaR1C1 = "EMP+FAMILY RATE"
Range("I1").FormulaR1C1 = "TOTAL"
Range("A2").FormulaR1C1 = "Base Epb"
Range("A3").FormulaR1C1 = "Base Monthly"
Range("A4").FormulaR1C1 = "Basen Epb"
Range("A5").FormulaR1C1 = "Basen Monthly"
Range("A6").FormulaR1C1 = "Buyup Epb"
Range("A7").FormulaR1C1 = "Buyup Monthly"
Range("A8").FormulaR1C1 = "Buyn Epb"
Range("A9").FormulaR1C1 = "Buyn Monthly"
Range("A10").FormulaR1C1 = "Civis Monthly"
Range("A11").FormulaR1C1 = "CIGNA Dental Choice"
Range("A12").FormulaR1C1 = "Dppo Dental Monthly"
Range("A13").FormulaR1C1 = "Dhmo Dental Monthly"

Range("B2").Resize(12, 3).FormulaR1C1 = _
"=SUMPRODUCT(--(TRIM(BillingLine)=RC1),--(TRIM(Tier)=R1C),--(AmountDue<>0))"

Range("F2").Resize(12, 3).FormulaR1C1 = _
"=IF(RC[-4]=0,0,SUMPRODUCT(--(TRIM(BillingLine)=RC1),--(TRIM(Tier)=R1C[-4]),AmountDue)/RC[-4])"
Range("A14").FormulaR1C1 = "BASE MEDICAL"
Range("A15").FormulaR1C1 = "BUY UP MEDICAL"
Range("A16").FormulaR1C1 = "TOTAL MEDICAL"
Range("A17").FormulaR1C1 = "DENTAL PPO"
Range("A18").FormulaR1C1 = "DENTAL HMO"
Range("A19").FormulaR1C1 = "TOTAL DENTAL"
Range("A20").FormulaR1C1 = "TOTAL VISION"
Range("A21").FormulaR1C1 = "GRAND TOTAL"
Range("B14:D14").FormulaR1C1 = "=R[-12]C+R[-10]C"
Range("B15:D15").FormulaR1C1 = "=R[-9]C+R[-7]C"
Range("B16:D16").FormulaR1C1 = "=R[-1]C+R[-2]C"
Range("B17:D17").FormulaR1C1 = "=R[-6]C+R[-5]C"
Range("B18:D18").FormulaR1C1 = "=R[-5]C"
Range("B19:D19").FormulaR1C1 = "=R[-1]C+R[-2]C"
Range("B20:D20").FormulaR1C1 = "=R[-10]C"
Range("E14:E20").FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
Range("F14:H14").FormulaR1C1 = "=SUMPRODUCT(R[-12]C[-4]:R[-9]C[-4],R[-12]C:R[-9]C)"
Range("F15:H15").FormulaR1C1 = "=SUMPRODUCT(R[-9]C[-4]:R[-6]C[-4],R[-9]C:R[-6]C)"
Range("F16:H16").FormulaR1C1 = "=R[-1]C+R[-2]C"
Range("F17:H17").FormulaR1C1 = "=SUMPRODUCT(R[-6]C[-4]:R[-5]C[-4],R[-6]C:R[-5]C)"
Range("F18:H18").FormulaR1C1 = "=R[-5]C[-4]*R[-5]C"
Range("F19:H19").FormulaR1C1 = "=R[-1]C+R[-2]C"
Range("F20:H20").FormulaR1C1 = "=R[-10]C[-4]*R[-10]C"
Range("F21:H21").FormulaR1C1 = "=R[-1]C+R[-2]C+R[-5]C"
Range("I14:I21").FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
Range("14:14,16:16,17:17,19:19,20:20,21:21").RowHeight = 25
Range("16:16,19:22").Font.Bold = True

Columns("A:I").EntireColumn.AutoFit
Range("A22").FormulaR1C1 = "AMOUNT DUE"
Range("I22").FormulaR1C1 = "=SUM(AmountDue)"
With Range("A22:I22").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With

Range("F2:I22").NumberFormat = "$#,##0.00"

ActiveSheet.PageSetup.PrintArea = "$A$1:$I$22"
With ActiveSheet.PageSetup
.PrintGridlines = True
.Orientation = xlLandscape
End With

MsgBox ("DONE")

End Sub

[/VBA]

Thanks.

Using Select is seldom needed and will slow code execution. Use With() to make sure that a Worksheet is set once.

e.g.
[vba]With Sheets("Counts")
.Range("B1").FormulaR1C1 = "EMP"
.Range("C1").FormulaR1C1 = "EMP+DEP"
End With [/vba]
For some other speedup tips and easy to use routines, see my kb entry: http://www.vbaexpress.com/kb/getarticle.php?kb_id=1035

I only have one select in there from what I can see......

Yes, but that is a speedup tip. If you view my code in my speedup routine, you will notice that I turn off screen updating and calculation. You have lots of that going on.

that helped a ton! thanks!!!

anyone have any tips involving the actual code i'm using? i'm always looking to learn :)

Thanks.

This speeds it up 4-fold:[vba]Sub blah1()
'StartTime = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'this sped it up the most
Dim numRecs As Long

Set SourceSheet = ActiveSheet
'name sheets
SourceSheet.Name = "Monthly Enrollment"
Set CountSht = Sheets.Add(After:=Sheets(Sheets.Count))

'name ranges
With SourceSheet
.Rows("1:5").Delete
numRecs = .Cells(.Rows.Count, "A").End(xlUp).Row - 1
With .Range("A1:A" & numRecs + 1)
.Offset(, 9).Name = "Subscribers"
.Offset(, 12).Name = "BillingLine"
.Offset(, 15).Name = "Tier"
'.Offset(, 17).Name = "Month" 'not used?
.Offset(, 21).Name = "AmountDue"
End With
.Range("W1").FormulaR1C1 = "Number of Lines"
.Range("W2").Resize(numRecs).FormulaR1C1 = "=COUNTIF(Subscribers,RC[-13])"

HeadersArray = Array("EMP", "EMP+DEP", "EMP+FAMILY", "TOTAL", "EMP RATE", "EMP+DEP RATE", "EMP+FAMILY RATE", "TOTAL")
ColumnHeadersArray = Array("Base Epb", "Base Monthly", "Basen Epb", "Basen Monthly", "Buyup Epb", "Buyup Monthly", "Buyn Epb", "Buyn Monthly", "Civis Monthly", "CIGNA Dental Choice", "Dppo Dental Monthly", "Dhmo Dental Monthly", "BASE MEDICAL", "BUY UP MEDICAL", "TOTAL MEDICAL", "DENTAL PPO", "DENTAL HMO", "TOTAL DENTAL", "TOTAL VISION", "GRAND TOTAL", "AMOUNT DUE")
With CountSht
.Name = "Counts"
.Range("B1:I1") = HeadersArray
.Range("A2:A22") = Application.Transpose(ColumnHeadersArray)
.Range("B2").Resize(12, 3).FormulaR1C1 = "=SUMPRODUCT(--(TRIM(BillingLine)=RC1),--(TRIM(Tier)=R1C),--(AmountDue<>0))"
.Range("F2").Resize(12, 3).FormulaR1C1 = "=IF(RC[-4]=0,0,SUMPRODUCT(--(TRIM(BillingLine)=RC1),--(TRIM(Tier)=R1C[-4]),AmountDue)/RC[-4])"

.Range("B14:D14").FormulaR1C1 = "=R[-12]C+R[-10]C"
.Range("B15:D15").FormulaR1C1 = "=R[-9]C+R[-7]C"
.Range("B17:D17").FormulaR1C1 = "=R[-6]C+R[-5]C"
.Range("B18:D18").FormulaR1C1 = "=R[-5]C"
.Range("B19:D19,B16:D16,F16:H16,F19:H19").FormulaR1C1 = "=R[-1]C+R[-2]C"
.Range("B20:D20").FormulaR1C1 = "=R[-10]C"
.Range("E14:E20,I14:I21").FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
.Range("F14:H14").FormulaR1C1 = "=SUMPRODUCT(R[-12]C[-4]:R[-9]C[-4],R[-12]C:R[-9]C)"
.Range("F15:H15").FormulaR1C1 = "=SUMPRODUCT(R[-9]C[-4]:R[-6]C[-4],R[-9]C:R[-6]C)"
.Range("F17:H17").FormulaR1C1 = "=SUMPRODUCT(R[-6]C[-4]:R[-5]C[-4],R[-6]C:R[-5]C)"
.Range("F18:H18").FormulaR1C1 = "=R[-5]C[-4]*R[-5]C"
.Range("F20:H20").FormulaR1C1 = "=R[-10]C[-4]*R[-10]C"
.Range("F21:H21").FormulaR1C1 = "=R[-1]C+R[-2]C+R[-5]C"
.Range("14:14,16:16,17:17,19:19,20:20,21:21").RowHeight = 25
.Range("16:16,19:22").Font.Bold = True
.Range("I22").FormulaR1C1 = "=SUM(AmountDue)"
.Range("F2:I22").NumberFormat = "$#,##0.00"

With .Range("A22:I22").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With

With .PageSetup
.PrintArea = "$A$1:$I$22"
.PrintGridlines = True
.Orientation = xlLandscape
End With
End With 'CountSht
'now back in With SourceSheet
.Select
.Range("A2").Select
ActiveWindow.FreezePanes = True
.Cells.EntireColumn.AutoFit
.Rows("1:1").AutoFilter
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
CountSht.Columns("A:I").EntireColumn.AutoFit
'MsgBox Timer - StartTime
MsgBox ("DONE")
End Sub
[/vba]A slight difference is that the named ranges are no longer dynamic, but that shouldn't matter.

If time is still a problem, it could probably be speeded up by doing all the calcualtions in-memory, by copying the source data into an array, creating another array or two in memory, then outputting them to the worksheets. The problems with that are (1) it would take some coding, (2) it would be difficult to adjust later.

Just wondering if you need to actually use the WS formulas since is looks like you're not going to update the source data. The formulas might not be needed and you could stay with VBA

i.e.

[VBA]
.Range("I22").value = Application.WorksheetFunction.Sum(AmountDue)
[/VBA]

Paul

thank you all so much. turning off autocalculate sped it up the most - got it to 11.6 seconds for 8000 rows. changing the code to the way you showed it cut it to 11.2 seconds :) so thank you - definitely learning a lot from the coding.

Thanks again!

Since the formulae on the Count sheet do not change at all, consider making the macro only change the defined names. Even this may not be needed if you kept (a version of) your dynamic ranges. The Count sheet should update itself. Then all you'd need to do is overwrite the values on the Monthly Enrolment sheet (and maybe copy the Count sheet to somewhere else, converting the formulae to values at the same time).

Not sure I understand what you mean......I am actually having this macro run from a different workbook on a spreadsheet that I download every month, not so much updating values once the macro is run

OK, I hadn't realised that. So are you saying that you have the above macro in a workbook and it adds a sheet to another workbook - namely the one that you download every month?
If so, following the same idea, tha attached file has only one worksheet, called Counts, (which acts as a template, containing all the formulae (mostly showing as #Name?), formatting, with a set print_area) and one macro (below) which when run, asks the user to identify the downloaded file (no checks that it's the right file and that it hasn't been processed before - as yet (also it assumes the first sheet is the source sheet)) then processes it by copying the Counts sheet to it and adding a few defined names, adding a column to the source sheet, autofilters it and freezes the panes on it.

I think you'll like the speed.

[vba]Sub blah4()
'get the target file and open it:
inputfilename = Application.GetOpenFilename("Excel,*.xls")
If inputfilename <> False Then
StartTime = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set inputfile = Workbooks.Open(inputfilename)
'now add a counts sheet to it:
With inputfile
.Sheets(1).Rows("1:5").Delete
'these names are dynamic but don't need to be, they can be defined as elsewhere:
.Names.Add Name:="Tier", RefersToR1C1:="=OFFSET('" & Sheets(1).Name & "'!R1C16,,,COUNTA('" & Sheets(1).Name & "'!C1))"
.Names.Add Name:="BillingLine", RefersToR1C1:="=OFFSET('" & Sheets(1).Name & "'!R1C13,,,COUNTA('" & Sheets(1).Name & "'!C1))"
.Names.Add Name:="AmountDue", RefersToR1C1:="=OFFSET('" & Sheets(1).Name & "'!R1C22,,,COUNTA('" & Sheets(1).Name & "'!C1))"
.Names.Add Name:="Subscribers", RefersToR1C1:="=OFFSET('" & Sheets(1).Name & "'!R1C10,,,COUNTA('" & Sheets(1).Name & "'!C1))"
.Sheets(1).Range("W1").FormulaR1C1 = "Number of Lines"
.Sheets(1).Range("W2").Resize(Range("Subscribers").Cells.Count - 1).FormulaR1C1 = "=COUNTIF(Subscribers,RC[-13])"
.Sheets(1).Name = "Monthly Enrollment"
ThisWorkbook.Sheets("Counts").Copy After:=.Sheets(1)
.Sheets("Counts").UsedRange.Formula = .Sheets("Counts").UsedRange.Formula
Application.Goto .Sheets(1).Range("A2"), True
ActiveWindow.ScrollRow = 1
ActiveWindow.FreezePanes = True
.Sheets(1).Cells.EntireColumn.AutoFit
.Sheets(1).Rows("1:1").AutoFilter
Application.Calculation = xlCalculationAutomatic
.Sheets("Counts").Columns("A:I").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox Timer - StartTime
'MsgBox ("DONE")
End If
'inputfile.save/saveas?
End Sub
[/vba]

yeah, so I was thinking of going that route at the beginning but then if someone goes in and changes a formula on that main sheet it will ruin it for everyone else. there are so many people who will be accessing this file that I figured it was just safer to have the macro write the formulas. (and protecting the formulas is not an option for some ridiculous political reasons)

thanks for all of your help though. learned a lot :)