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