tkaplan
03-29-2011, 01:21 PM
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:
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
Thanks.
workbook with code attached and code is below as well:
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
Thanks.