Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 5
Default faster macro

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


  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 2,253
Default faster macro

Tim,

I'll get to work on this. Mail you when I'm done.

The main speed increase will probably come from disabling recalculation,
screenupdating etc..

I'll also rewrite it bit to put the loops in a loop instead of
repeating same code 6 times.


keepITcool

< email : keepitcool chello nl (with @ and .)
< homepage: http://members.chello.nl/keepitcool


"_______Tim_______" wrote:

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


  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 27,285
Default 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




  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 2,253
Default faster macro

Tom

It's probably more in the sequencing of the loops.
PLUS he's copying individual cells rather than ranges.
AND he's not disabling events/calculation nor screenupdating.

like they say... it's rather confusing :)

at present he's looping
10 blocks of 6000 scenarios of 10 cells

whereas his intention may be:
10 blocks of 10 scenarios of 6000 cells.

i've sent OP a mail. waiting for reaction.


keepITcool

< email : keepitcool chello nl (with @ and .)
< homepage: http://members.chello.nl/keepitcool


"Tom Ogilvy" wrote:

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,

  #5   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 5
Default 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


.



Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
How can my macro run faster ? Roger[_2_] New Users to Excel 12 October 26th 09 12:57 PM
How do I print faster? vito Excel Discussion (Misc queries) 3 August 26th 09 06:18 PM
WHY the same macro runs so slowly on a different but faster comput Jerry Excel Discussion (Misc queries) 2 August 15th 07 10:30 PM
can this be done faster? Frank Excel Discussion (Misc queries) 7 August 9th 07 10:02 PM
Can faster CPU+larger/faster RAM significantly speed up recalulati jmk_li Excel Discussion (Misc queries) 2 September 28th 05 10:24 AM


All times are GMT +1. The time now is 03:39 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"