faster macro
At the top of the procedure
Application.Calculation = xlManual
at the bottom of the procedure
Application.Calculation = xlAutomatic
running the code on a sheet doing almost no calculation to about 2.5 minutes
on my machine - setting calculation to manual reduced that to a little less
than 2 minutes. So trying to minimize the amount of calculation should be
your biggest savings.
--
Regards,
Tom Ogilvy
_______Tim_______ wrote in message
...
Hi,
I am using this macro to run numbers through a calculator
in another sheet. It takes numbers from the same columns
except for one column, row to row and deposits the results
in another column. Basically it is the same sub routine
duplicated to shift to the variable column 10 times. This
macro takes 4 hours to run 10 columns of new data through
5,000 - 10,000 rows of data depending on the size of the
sheet. Is there a way to write this macro so it finishes
faster? If you need more information, let me know.
Regards, Tim
Option Explicit
Sub forecastupto10()
Dim callsWks As Worksheet
Dim FRCSTWks As Worksheet
Dim rCtr As Long 'row counter
Dim FirstRow As Long
Dim LastRow As Long
Dim cCtr As Long 'col counter
Dim beforeCol As Variant 'on calls
Dim beforeAddress As Variant 'on FRCST
Dim afterCol As Variant 'on calls
Dim afterAddress As Variant 'on FRCST
Set callsWks = Worksheets("calls")
Set FRCSTWks = Worksheets("FRCST")
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "bz", "aq", "ap") '1
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "C12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("ca")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cb", "aq", "ap") '2
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("cc")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cd", "aq", "ap") '3
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("ce")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cf", "aq", "ap") '4
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("cg")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "ch", "aq", "ap") '5
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("ci")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cj", "aq", "ap") '6
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("ck")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cl", "aq", "ap") '7
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("cm")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cn", "aq", "ap") '8
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("co")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cp", "aq", "ap") '9
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("cq")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count,
' beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
beforeCol = Array
("e", "j", "q", "k", "aa", "ai", "cr", "aq", "ap") '10
beforeAddress = Array
("C5", "C6", "C7", "C8", "C9", "C10", "C11", "c12", "C13")
If UBound(beforeCol) < UBound(beforeAddress) Then
MsgBox "Error in before layout!"
Exit Sub
End If
afterCol = Array("cs")
afterAddress = Array("C20")
If UBound(afterCol) < UBound(afterAddress) Then
MsgBox "Error in after layout!"
Exit Sub
End If
With callsWks
FirstRow = 12 '???
LastRow = 6763
'LastRow = .Cells(.Rows.Count, _
beforeCol(LBound
(beforeCol))).End(xlUp).Row
For rCtr = FirstRow To LastRow
'move 'em in
For cCtr = LBound(beforeCol) To UBound
(beforeCol)
FRCSTWks.Range(beforeAddress(cCtr)).Value _
= .Cells(rCtr, beforeCol(cCtr))
Next cCtr
Application.Calculate 'just to make sure
'head 'em out
For cCtr = LBound(afterCol) To UBound(afterCol)
.Cells(rCtr, afterCol(cCtr)).Value _
= FRCSTWks.Range(afterAddress
(cCtr)).Value
Next cCtr
'rawhide <bg
Next rCtr
End With
End Sub
|