Ampel / Traffic Light Program

[Benjamin1978]

Hi All

I have here a Program which is a little bit a playing around with OnTime Functions but i'm up to it to get it running .... i know there are some Programs in the web but i want to learn it the hard way :-)
It runs fine in Automatic and Tip Modus .... but then shows a strange message after the first loop in GoTo Wort2 :
Cannot Run the Macros "C.... ampel12.xlsm.......... The Macro may not be available in the workbook or all macros may be disabled.....

I think it is the loop which is the Problem but i'm not sure ..............

What i want with the Program is to show me the normal Traffic Light Sequence in a Time interval and should finish after 5 runs

Please give me some tips how to get it running smooth ......Cheers



Code:

Private Sub Ampel_3Lights()
Dim i As Long
    i = 0
    Do While i < 5
    Application.OnTime EarliestTime:=Now + TimeSerial(o, 0, 5), Procedure:="GoTo Wort1"
    Application.OnTime EarliestTime:=Now + TimeSerial(o, 0, 10), Procedure:="GoTo Wort2"
    Application.OnTime EarliestTime:=Now + TimeSerial(o, 0, 15), Procedure:="GoTo Wort3"
    Application.OnTime EarliestTime:=Now + TimeSerial(o, 0, 20), Procedure:="GoTo Wort4"
Wort1:
    Range("F6").Select
        With Selection.Interior
        .ThemeColor = xlThemeColorLight1
        End With
            Range("F7").Select
            With Selection.Interior
            .ThemeColor = xlThemeColorLight1
            End With
                Range("F8").Select
                With Selection.Interior
                .Color = 5296274
                End With
Wort2:
    Range("F6").Select
        With Selection.Interior
        .ThemeColor = xlThemeColorLight1
        End With
            Range("F7").Select
            With Selection.Interior
            .ThemeColor = xlThemeColorLight1
            End With
                Range("F8").Select
                With Selection.Interior
                .ThemeColor = xlThemeColorLight1
                End With

Wort3:
    Range("F6").Select
        With Selection.Interior
        .ThemeColor = xlThemeColorLight1
        End With
            Range("F7").Select
            With Selection.Interior
            .Color = 49407
            End With
                Range("F8").Select
                With Selection.Interior
                .Color = 5296274
                End With

Wort4:
    Range("F6").Select
        With Selection.Interior
        .Color = 255
        End With
            Range("F7").Select
            With Selection.Interior
            .ThemeColor = xlThemeColorLight1
            End With
                Range("F8").Select
                With Selection.Interior
                .ThemeColor = xlThemeColorLight1
                End With
                        i = i + 1
    Loop
End Sub

[romperstomper]

You cannot use OnTime to jump to part of a procedure. You would need to separate out each section into its own procedure and call that from OnTime.

[teylyn]

Danke, für Dein Verständnis, Benjamin! Ich hab die Posts gelöscht, damit der Thread mit weniger Antworten mehr Aufmerksamkeit bekommt. Aber mit romperstomper bist Du in guten Händen.

cheers

[romperstomper]

Nur guten??

[teylyn]

In den besten, natürlich!!

shall we move this to the foreign language forum?

[Benjamin1978]

Hi Romperstomper ......
thx for the fast Replay
I though about your idea but struggle to put a loop in to the routin.......
other Idea is to get

Application.OnTime Now + TimeValue("00:00:2"), 
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 11

in to 1 Block but don't know yet how to get

Application.OnTime Now + TimeValue("00:00:2"), HOW TO CONNECT ?????? 
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 8

together


Here is the second Code : on a endless loop but what ever i do i fail to get it in to a loop

Sub Button_Click1()
Application.OnTime Now + TimeValue("00:00:2"), "GREEN_5SEC"
End Sub
Sub GREEN_5SEC()
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 11
Application.OnTime Now + TimeValue("00:00:5"), "YELLOW_1SEC"
End Sub
Sub YELLOW_1SEC()
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 13
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 8
Application.OnTime Now + TimeValue("00:00:1"), "YELLOWRED_1SEC"
End Sub
Sub YELLOWRED_1SEC()
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 10
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 13
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 8
Application.OnTime Now + TimeValue("00:00:1"), "RED_5SEC"
End Sub
Sub RED_5SEC()


Cheers 

Regards Ben 
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 10
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 8
Application.OnTime Now + TimeValue("00:00:5"), "GREEN_5SEC"
End Sub

[romperstomper]

Your second code should work - what is it doing wrong?

[Benjamin1978]

I just want to build in a loop to stop it after 20 times ...... just now it's on a endless loop

[romperstomper]

Try this:

Dim lngCounter as long
Sub Button_Click1()
lngCounter = 1
Application.OnTime Now + TimeValue("00:00:2"), "GREEN_5SEC"
End Sub
Sub GREEN_5SEC()
If lngCounter < 21 then
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 11
Application.OnTime Now + TimeValue("00:00:5"), "YELLOW_1SEC"
End If
End Sub
Sub YELLOW_1SEC()
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 13
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 8
Application.OnTime Now + TimeValue("00:00:1"), "YELLOWRED_1SEC"
End Sub
Sub YELLOWRED_1SEC()
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 10
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 13
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 8
Application.OnTime Now + TimeValue("00:00:1"), "RED_5SEC"
End Sub
Sub RED_5SEC()
ActiveSheet.Shapes("AutoShape 9").Fill.ForeColor.SchemeColor = 10
ActiveSheet.Shapes("AutoShape 8").Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("AutoShape 7").Fill.ForeColor.SchemeColor = 8
lngCounter = lngCounter + 1
Application.OnTime Now + TimeValue("00:00:5"), "GREEN_5SEC"
End Sub

[Benjamin1978]

Hi

I had this Problem before ... i doesn't recorgnize the loop

[romperstomper]

Works perfectly for me - see attached.

[Benjamin1978]

Hi


Works now for me as well .......closed down Project and opened it fresh and it working now

Thx for the Help