faster macro
Thank you all for great information. I added the code Tom
suggested and cut the run time in half! Some of the other
suggestions are way above my head for now. I am sure this
workbook can be optimized in many ways, but I just don't
know enough to make that happen. keepITcool has requested
a sample workbook, which I am putting together for him.
If anyone else would like one let me know. I have a macro
I use on another project that I think could be modified
for this application. With this other macro I just tell
it what file to get and the file is brought into an excel
sheet and all the calculations are done! Even if using
this other macro method were not faster, it would be nice
to start it and walk away. I can also provide you with
this sample macro and workbooks if you are interested.
Again, thank you all for your help.
Regards, Tim
-----Original 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
.
|