Help with speeding up macro

  • Thread starter Thread starter Matt Knight
  • Start date Start date
M

Matt Knight

Evening all,

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
If I understand your macro correctly, your code is inefficient. You
don't have to select a sheet to work on it with VBA. You don't have to
select a cell to copy it and you don't have to select a cell to paste into
it. I think your code does the same thing to each of 3 sheets, same cells
and all. The following is not tested and uses a For loop through the 3
sheets. I left the formula part open since I couldn't figure out what the
formula does. Perhaps VBA could be used to simply calculate the answer
without pasting a formula. Your call on that. This will give you something
to chew on. Come back if you need more. HTH Otto
Sub driver_calc()
Application.ScreenUpdating = False
Dim myLC As Long
Dim myLR As Long
Dim myLRr As Long
Dim myLCr As Long
Dim ws As Worksheet
For Each ws In Sheets(Array("Driver 1 - STUDENTS", "Driver 2 - TIME",
"Driver 3 - STUDENTSxTIME"))
With ws
myLC = .Range("IV4").End(xlToLeft).Column
myLR = .Cells(Rows.Count, "C").End(xlUp).Row
myLCr = .Range("IV6").End(xlToLeft).Column
myLRr = .Cells(Rows.Count, "E").End(xlUp).Row
.Range("E6", .Cells(myLR, myLC)).ClearContents
'Calculate or place formula in E6
.Range("E6").Copy .Range("E6:E" & myLR)
.Range("E6:E" & myLR).Copy .Range("E6", .Cells(myLR, myLC))
.Range("E6", Cells(myLR, myLC)).Copy
'In the next line, type in the range to paste in. Put a period
in front of it.
'Selection.PasteSpecial Paste:=xlPasteValues
.Calculate
End With
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
Worksheets("Costing Model & Sensitivity").Select
MsgBox "Drivers succesfully updated", vbInformation, "Lxxxxxxxxxxxxxxxx"
End Sub
 
Hi Otto, Thanks a million for your reply,

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
 
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
(e-mail address removed). Remove the "extra" from this address. Otto
 
My apologies - the first sentence above was meant to read:

"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
 
I don't have data, so I'm not sure if this would work or not. And
besides, I'm not sure if this would speed up or not, but try this one.

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
 
Back
Top