Copy and paste range ontime

[Rob]

Hi,
I need to copy a static range and paste to specific cells at specific times.
The time interval is over 370 minutes. Here is the code that seems to work
well.

Sub CopyVolume1()
Range("C2:C4").Select
Selection.Copy
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
End Sub

Public Sub Time()
Application.OnTime TimeValue("14:07:00"), "CopyVolume1"
Application.OnTime TimeValue("14:08:00"), "CopyVolume2"
Application.OnTime TimeValue("14:09:00"), "CopyVolume3"
End Sub

Sub CopyVolume2()
Range("C2:C4").Select
Selection.Copy
Range("e2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
End Sub

Sub CopyVolume3()
Range("C2:C4").Select
Selection.Copy
Range("f2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
End Sub

Is there a way to do this with out having to copy and paste the Sub
CopyVolume3
until I have 370 Sub CopyVolumes and 370 Application.OnTime
TimeValue("14:09:00"), "CopyVolume3". Each time having to enter the various
parameters ?

 

[Dave Peterson]

I've never set up 370 different ontime routines and I'm not sure how excel will
react.

Instead, I'd use a single ontime procedure that instructs itself to run once
more in a minute.

This is based on Chip Pearson's OnTime instructions:
http://www.cpearson.com/Excel/OnTime.aspx

(Untested, but it did compile)

Option Explicit
Public RunWhen As Double
Public Const cRunWhat = "DoTheCopy" ' the name of the procedure to run
Dim DestCell As Range
Dim sCtr As Long
Dim WhichSheet As Range
Sub StartTimer()

If WhichSheet Is Nothing Then
'initialize the variables
Set WhichSheet = ThisWorkbook.Worksheets("sheet1")
Set DestCell = WhichSheet.Range("c2")
sCtr = 1
RunWhen = Now + TimeSerial(14, 7, 0)
End If

Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub TheSub()

With WhichSheet
.Range("C2:C4").Copy
DestCell.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With

'get ready for next time
If sCtr <= 370 Then
sCtr = sCtr + 1
RunWhen = RunWhen + TimeSerial(0, 1, 0)
Set DestCell = DestCell.Offset(0, 1)
StartTimer ' Reschedule the procedure
End If
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=False
End Sub

 

[Rob]

I've never set up 370 different ontime routines and I'm not sure how excel will
react.

Instead, I'd use a single ontime procedure that instructs itself to run once
more in a minute.

This is based on Chip Pearson's OnTime instructions:
http://www.cpearson.com/Excel/OnTime.aspx

(Untested, but it did compile)

Option Explicit
Public RunWhen As Double
Public Const cRunWhat = "DoTheCopy" ' the name of the procedure to run
Dim DestCell As Range
Dim sCtr As Long
Dim WhichSheet As Range
Sub StartTimer()

If WhichSheet Is Nothing Then
'initialize the variables
Set WhichSheet = ThisWorkbook.Worksheets("sheet1")
Set DestCell = WhichSheet.Range("c2")
sCtr = 1
RunWhen = Now + TimeSerial(14, 7, 0)
End If

Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub TheSub()

With WhichSheet
.Range("C2:C4").Copy
DestCell.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With

'get ready for next time
If sCtr <= 370 Then
sCtr = sCtr + 1
RunWhen = RunWhen + TimeSerial(0, 1, 0)
Set DestCell = DestCell.Offset(0, 1)
StartTimer ' Reschedule the procedure
End If
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=False
End Sub




--

Dave Peterson
.
Thank you Dave.