A colleague and I are just having some issues with a macro's speed in
Excel 2003 (in '07 it takes about 1m40, which I could live with, but
in 03, I've not managed to wait it out till the end yet...).
Basically, what we're doing is devising a costing model for a college
so that it can apportion overheads into courses. This requires using
various drivers (three to be precise) and taking percentages so that
the split accuratly reflects the activity undertaken by each course.
Anyway, that's just some background that will probably be of no use.
But the macro we're having trouble with is with the driver calcs.
Basically we've set it up to run a formula and paste the value it
returns down a column and then across the rest of the sheet (for each
of the 3 drivers). This involves over 170,000 calculations (and yes,
we need this many). Anyway, the code is as follows:
"Sub driver_calc()
Application.ScreenUpdating = False
Dim myLC As Long
Dim myLR As Long
Dim myLRr As Long
Dim myLCr As Long
'Driver 1 Calculation
Sheets("Driver 1 - STUDENTS").Select
myLC = ActiveSheet.Range("IV4").End(xlToLeft).Column
myLR = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
myLCr = ActiveSheet.Range("IV6").End(xlToLeft).Column
myLRr = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
Range("E6", Cells(myLR, myLC)).Select
Selection.ClearContents
Range("E6").Select
ActiveCell.Formula = "=if(sumproduct(--('course list by division'!$c
$6:$C$607=E$4),'Course list by division'!$i$6:$i$607)=0,0,sumproduct(--
('course list by division'!$E$6:$e$607=$b6),--('course list by
division'!$c$6:$c$607=E$4),'course list by division'!$i$6:$i$607)/
sumproduct(--('Course list by division'!$c$6:$c$607=E$4),'course list
by division'!$i$6:$i$607))"
Range("E6").Copy
Range("E6:E" & myLR).Select
ActiveSheet.Paste
Range("E6:E" & myLR).Copy
Range("E6", Cells(myLR, myLC)).Select
ActiveSheet.Paste
ActiveSheet.Calculate
Range("E6", Cells(myLR, myLC)).Copy
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone,
skipblanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Driver 2 Calculation
Sheets("Driver 2 - TIME").Select
myLC = ActiveSheet.Range("IV4").End(xlToLeft).Column
myLR = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
myLCr = ActiveSheet.Range("IV6").End(xlToLeft).Column
myLRr = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
Range("E6", Cells(myLR, myLC)).Select
Selection.ClearContents
Range("E6").Select
ActiveCell.Formula = "=if(sumproduct(--('course list by division'!$c
$6:$C$607=E$4),'Course list by division'!$j$6:$j$607)=0,0,sumproduct(--
('course list by division'!$E$6:$e$607=$b6),--('course list by
division'!$c$6:$c$607=E$4),'course list by division'!$J$6:$J$607)/
sumproduct(--('Course list by division'!$c$6:$c$607=E$4),'course list
by division'!$J$6:$J$607))"
Range("E6").Copy
Range("E6:E" & myLR).Select
ActiveSheet.Paste
Range("E6:E" & myLR).Copy
Range("E6", Cells(myLR, myLC)).Select
ActiveSheet.Paste
ActiveSheet.Calculate
Range("E6", Cells(myLR, myLC)).Copy
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone,
skipblanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Driver 3 Calculation
Sheets("Driver 3 - STUDENTSxTIME").Select
myLC = ActiveSheet.Range("IV4").End(xlToLeft).Column
myLR = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
myLCr = ActiveSheet.Range("IV6").End(xlToLeft).Column
myLRr = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
Range("E6", Cells(myLR, myLC)).Select
Selection.ClearContents
Range("E6").Select
ActiveCell.Formula = "=if(sumproduct(--('course list by division'!$c
$6:$C$607=E$4),'Course list by division'!$K$6:$K$607)=0,0,sumproduct(--
('course list by division'!$E$6:$e$607=$b6),--('course list by
division'!$c$6:$c$607=E$4),'course list by division'!$K$6:$K$607)/
sumproduct(--('Course list by division'!$c$6:$c$607=E$4),'course list
by division'!$K$6:$K$607))"
Range("E6").Copy
Range("E6:E" & myLR).Select
ActiveSheet.Paste
Range("E6:E" & myLR).Copy
Range("E6", Cells(myLR, myLC)).Select
ActiveSheet.Paste
ActiveSheet.Calculate
Range("E6", Cells(myLR, myLC)).Copy
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone,
skipblanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Application.ScreenUpdating = True
Worksheets("Costing Model & Sensitivity").Select
MsgBox "Drivers succesfully updated", vbInformation,
"Lxxxxxxxxxxxxxxxx"
End Sub"
We were just wandering if there was anything in there that we could
change to make the macro run more efficiently (namely, how to run the
if(sumproduct(......)) formulae "separately" rather than have the
macro enter it into each cell, calculate and then paste the value).
Any help/advice would, as always, be greatly appreciated.
Cheers
Matt
"Matt Knight" <mattkni...@googlemail.com> wrote in message
news:61956656-db4c-44b9...@l30g2000yqb.googlegroups.com...
I started to try and use your solution before realising that on each
sheet- I don't know how I'd go about addressing that with your
solution. What the formulas are essentially doing is figuring out
percentages of students/time/students*time on each course within a
cost centre to then allocate overhead accordingly (I doubt that
explanation is of any help, but you never know!).
Any other thoughts??
Many thanks
Matt
On Jan 5, 7:03 pm, "Otto Moehrbach" <moehrbachoex...@bellsouth.net>
wrote:
> "Matt Knight" <mattknight1...@googlemail.com> wrote in message
"Matt Knight" <mattkni...@googlemail.com> wrote in message
news:faef66ea-eb77-4dcb...@j5g2000yqm.googlegroups.com...
"I started to try and use your solution before realising that I'm
using a different formula on each sheet".
I'm about to email you anyway, but hopefully that makes more sense!
Matt
On Jan 6, 5:49 pm, "Otto Moehrbach" <moehrbachoex...@bellsouth.net>
wrote:
> Matt
> I don't follow what you said about ".....each sheet....". If you wish,
> send me your file or a sample of it. Fake the data if you wish, I need just
> the layout. Tell me the version of Excel you're using. Include a copy of
> the posts you and I made on this. Give me as much explanation as you can
> about what you want to do. Pretend that you have to do everything manually
> with pencil and paper. What would you do? My email is
> moehrbachoex...@bellsouth.net. Remove the "extra" from this address. Otto
Sub driver_calcTest()
Application.ScreenUpdating = False
Dim myLC As Long
Dim myLR As Long
Dim myLRr As Long
Dim myLCr As Long
'Driver 1 Calculation
Sheets("Driver 1 - STUDENTS").Select
myLC = ActiveSheet.Range("IV4").End(xlToLeft).Column
myLR = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
myLCr = ActiveSheet.Range("IV6").End(xlToLeft).Column
myLRr = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
Range("E6", Cells(myLR, myLC)).ClearContents
Application.Calculation = xlCalculationManual
Range("E6").Formula = "=if(sumproduct(--('course list by
division'!$c$6:$C$607=E$4),'Course list by
division'!$i$6:$i$607)=0,0,sumproduct(--('course list by
division'!$E$6:$e$607=$b6),--('course list by
division'!$c$6:$c$607=E$4),'course list by
division'!$i$6:$i$607)/sumproduct(--('Course list by
division'!$c$6:$c$607=E$4),'course list by division'!$i$6:$i$607))"
Range("E6").Copy Range("E6", Cells(myLR, myLC))
Application.Calculation = xlCalculationAutomatic
Range("E6", Cells(myLR, myLC)) = Range("E6", Cells(myLR, myLC)).Value
'Driver 2 Calculation
Sheets("Driver 2 - TIME").Select
myLC = ActiveSheet.Range("IV4").End(xlToLeft).Column
myLR = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
myLCr = ActiveSheet.Range("IV6").End(xlToLeft).Column
myLRr = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
Range("E6", Cells(myLR, myLC)).ClearContents
Application.Calculation = xlCalculationManual
Range("E6").Formula = "=if(sumproduct(--('course list by
division'!$c$6:$C$607=E$4),'Course list by
division'!$j$6:$j$607)=0,0,sumproduct(--('course list by
division'!$E$6:$e$607=$b6),--('course list by
division'!$c$6:$c$607=E$4),'course list by
division'!$J$6:$J$607)/sumproduct(--('Course list by
division'!$c$6:$c$607=E$4),'course list by division'!$J$6:$J$607))"
Range("E6").Copy Range("E6", Cells(myLR, myLC))
Application.Calculation = xlCalculationAutomatic
Range("E6", Cells(myLR, myLC)) = Range("E6", Cells(myLR, myLC)).Value
'Driver 3 Calculation
Sheets("Driver 3 - STUDENTSxTIME").Select
myLC = ActiveSheet.Range("IV4").End(xlToLeft).Column
myLR = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
myLCr = ActiveSheet.Range("IV6").End(xlToLeft).Column
myLRr = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
Range("E6", Cells(myLR, myLC)).ClearContents
Application.Calculation = xlCalculationManual
Range("E6").Formula = "=if(sumproduct(--('course list by
division'!$c$6:$C$607=E$4),'Course list by
division'!$K$6:$K$607)=0,0,sumproduct(--('course list by
division'!$E$6:$e$607=$b6),--('course list by
division'!$c$6:$c$607=E$4),'course list by
division'!$K$6:$K$607)/sumproduct(--('course list by
division'!$c$6:$c$607=E$4),'course list by division'!$K$6:$K$607))"
Range("E6").Copy Range("E6", Cells(myLR, myLC))
Application.Calculation = xlCalculationAutomatic
Range("E6", Cells(myLR, myLC)) = Range("E6", Cells(myLR, myLC)).Value
Application.ScreenUpdating = True
Worksheets("Costing Model & Sensitivity").Select
MsgBox "Drivers succesfully updated", vbInformation, "Lxxxxxxxxxxxxxxxx"
End Sub
Keiji