Loop Unitl with timer

[blackbox via OfficeKB.com]

I have range of values in columns A & B which I would like to display 1 at a
time, at 1 second intervals in cells D4 and E4

I have some code but I'm not very good with loops.
How would I make this move from row 1 to row2 to row 3, etc.. at every 1
second re-fresh?

Public RunWhen As Double
Public Const cRunIntervalSeconds = 1 ' 1 second
Public Const cRunWhat = "Run_Time_and_Sales"

Sub StartTimer()
If Range("F1") = "x" Then
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
schedule:=True
Else: End
End If
End Sub

Sub Run_Time_and_Sales()

Dim LastPrint As Integer
Dim PrintTime As Integer

LastPrint = Range("A1").Value
PrinTime = Range("B1").Value

Range("D4") = LastPrint
Range("E4") = PrintTime


StartTimer

End Sub

 

[Guest]

In your Run_Time_and_Sales() routine you need to be able to determine when to
loop back and pick up the first cell, and you need something to keep track of
where you are. You could set up a Static variable in the routine to keep up
with the "where" and the last row (so you can loop back).

Perhaps this code (which would do what you want) will give you some ideas of
how to deal with it.

Sub ShowAtOneSecondIntervals()
Const DelayInSeconds = 1
Dim rOffset As Long
Dim lastRow As Long
Dim neverEndFlag As Boolean
Dim stime As Long
Dim dcOne As Range
Dim dcTwo As Range
Dim baseCellOne As Range
Dim baseCellTwo As Range

'change worksheet name as required
Set dcOne = Worksheets("Sheet2").Range("D4")
Set dcTwo = Worksheets("Sheet2").Range("E4")
Set baseCellOne = Worksheets("Sheet2").Range("A1")
Set baseCellTwo = Worksheets("Sheet2").Range("B1")

lastRow = Range("A1").End(xlDown).Row
Do Until neverEndFlag ' never ends
dcOne.Value = baseCellOne.Offset(rOffset, 0).Value
dcTwo.Value = baseCellTwo.Offset(rOffset, 0).Value
stime = Timer
Do Until Timer > stime + DelayInSeconds
DoEvents ' allow other things to happen
Loop
rOffset = rOffset + 1
If rOffset = lastRow Then
rOffset = 0
End If
Loop
End Sub