Cómo ejecutar un bucle hasta que se presione una tecla.

Puedes poner tu macro.

Una disculpa se me pasó poner el código. Aquí está:

Dim Cuenta1 As Range
Dim ejecutando1 As Boolean
Dim NO1 As String
Public Iniciar1 As Date

Sub setcrono1()
ejecutando1 = True
Set Cuenta1 = [K3]
[F3] = [K3]
Call ProgramaCuentaRegresiva1
End Sub

Sub ProgramaCuentaRegresiva1()
Iniciar1 = Now + TimeValue("00:00:01")
Application.OnTime Earliesttime:=Iniciar1, procedure:="ProgramaCuenta1", Schedule:=True
End Sub

Sub ProgramaCuenta1()

Dim s As Integer
Dim hora As String

Set Cuenta1 = [F3]

Cells(3, 7).Interior.ColorIndex = 2
Cuenta1.Value = Cuenta1.Value - TimeSerial(0, 0, 1)

If Cuenta1 <= 0 Then
hora = Format(Now, "HH:mm:ss")
If hora > "15:30:00" Then
Call EnviarEmail1
End If
    For i = 0 To 1
      Call SonidoControlado
         For q = 0 To 2500
           Cells(3, 7).Interior.ColorIndex = 3
       Next
     q = 0
     For q = 0 To 2500
     Cells(3, 7).Interior.ColorIndex = 2
     Next
Next
Cells(3, 7).Interior.ColorIndex = 3
NO1 = Sheet1.Range("B3").Text
MsgBox "Terminó el Tiempo de Proceso Traveler " + NO1, vbExclamation
Call apagarcrono1
Exit Sub

End If

Call ProgramaCuentaRegresiva1

End Sub

Sub apagarcrono1()
ejecutando = False
On Error Resume Next
Application.OnTime Earliesttime:=Iniciar1, procedure:="ProgramaCuenta1", Schedule:=False
End Sub

La parte que necesito que se repita es:

 For i = 0 To 1
      Call SonidoControlado
         For q = 0 To 2500
           Cells(3, 7).Interior.ColorIndex = 3
       Next
     q = 0
     For q = 0 To 2500
     Cells(3, 7).Interior.ColorIndex = 2
     Next

En lugar del For i=0 .... poner algo como do while hasta que se presione enter o space

No se puede poner una tecla, ya que la definición On Key funciona llamando a una macro, pero ya tienes una macro en ejecución.

Prueba lo siguiente, tu macro quedaría así:

Sub ProgramaCuenta1()
    Dim s As Integer
    Dim hora As String
    Set Cuenta1 = [F3]
    Cells(3, 7).Interior.ColorIndex = 2
    Cuenta1.Value = Cuenta1.Value - TimeSerial(0, 0, 1)
    If Cuenta1 <= 0 Then
        hora = Format(Now, "HH:mm:ss")
        If hora > "15:30:00" Then
            Call EnviarEmail1
        End If
        '
        Cells(3, "H") = ""
        parpadear
        '
        Cells(3, 7).Interior.ColorIndex = 3
        NO1 = Sheet1.Range("B3").Text
        MsgBox "Terminó el Tiempo de Proceso Traveler " + NO1, vbExclamation
        Call apagarcrono1
        Exit Sub
    End If
    Call ProgramaCuentaRegresiva1
End Sub

En otro módulo pon la siguiente macro:

Sub parpadear()
    If Cells(3, 8) <> "" Then
        Exit Sub
    End If
    Call SonidoControlado
    If Cells(3, 7).Interior.ColorIndex = 3 Then
        Cells(3, 7).Interior.ColorIndex = 2
    Else
        Cells(3, 7).Interior.ColorIndex = 3
    End If
    Application.OnTime Earliesttime:=Now + TimeValue("00:00:01"), procedure:="parpadear", Schedule:=True
End Sub

Lo que hace es ejecutar la macro parpadear hasta que la celda H3 sea igual a blanco, si escribes algo en la celda H3, entonces se detendrá la macro papadear.

Prueba y me comentas.

':)
S a l u d o s . D a n t e A m o r
':) Si es lo que necesitas. Recuerda valorar la respuesta. G r a c i a s.

Gracias Dante por tu ayuda.

Hice algunas modificaciones pero básicamente es el código que me pasaste. Quedo de esta manera:

Sub setcrono1()
ejecutando1 = True
Set Cuenta1 = [K3]
[G3] = [K3]
Call ProgramaCuentaRegresiva1
End Sub
Sub ProgramaCuentaRegresiva1()
    Iniciar1 = Now + TimeValue("00:00:01")
    Application.OnTime Earliesttime:=Iniciar1, procedure:="ProgramaCuenta1", Schedule:=True
End Sub
Sub ProgramaCuenta1()
Dim NO1 As String
Dim s As Integer
Dim hora As String
    Set Cuenta1 = [G3]
    Cells(3, 8).Interior.ColorIndex = 2
    Cuenta1.Value = Cuenta1.Value - TimeSerial(0, 0, 1)
    If Cuenta1 <= 0 Then
       hora = Format(Now, "HH:mm:ss")
             If hora > "15:30:00" Then
              Call EnviarEmail1
             End If
            NO1 = Sheet1.Range("B3").Text
            Sheet1.Range("J3") = ""
            Cells(3, "J") = ""
            Call avisa(NO1)
            Cells(3, 8).Interior.ColorIndex = 3
            Call apagarcrono1
        Exit Sub
    End If
Call ProgramaCuentaRegresiva1
End Sub
Sub apagarcrono1()
ejecutando = False
On Error Resume Next
Application.OnTime Earliesttime:=Iniciar1, procedure:="ProgramaCuenta1", Schedule:=False
End Sub

Y la función parpadear que la renombre avisa quedo:

Sub avisa(Optional NO As String)
SO1 = NO
Sheet1.Range("J3").Select
 If Cells(3, 10) <> "" Then
    SO1 = NO
    MsgBox "Terminó el Tiempo de Proceso del Traveler " + SO1, vbExclamation
    Exit Sub
 End If
   Call SonidoControlado
    For q = 0 To 1000
       Cells(3, 8).Interior.ColorIndex = 3
    Next
    q = 0
    For q = 0 To 1000
      Cells(3, 8).Interior.ColorIndex = 2
    Next
     Application.OnTime Earliesttime:=Now + TimeValue("00:00:01"), procedure:="avisa", Schedule:=True
End Sub

por cierto en esta ultimo tengo problemas para guardar el valor de la variable NO que le estoy enviando como argumento si lo recibe pero despues de algunas iteraciones se vacía y no aparece en el msg box (variable SO1). Será por la función application.ontime?

H o l a:

Si probaste la macro que te envié hace lo que solicitaste, la celda va a parpadear hasta que escribas algo.

Como te expliqué no es posible que mediante una tecla se pueda detener el parpadeo, ya que el parpadeo es originado por una macro que está en ejecución.

Otra parte que actualicé en la macro es esto:

For q = 0 To 1000
       Cells(3, 8).Interior.ColorIndex = 3
    Next

Lo que hace esa parte es poner 1000 veces el mismo color 3 a la celda, entonces no parpadea, para lograr el efecto de parpadear, podría ser así:

    If Cells(3, 7).Interior.ColorIndex = 3 Then
        Cells(3, 7).Interior.ColorIndex = 2
    Else
        Cells(3, 7).Interior.ColorIndex = 3
    End If

Lo pone en color 2, a la siguiente vez lo pone en color 3 y así sucesivamente.

Por otra parte, para que la variable NO conserve su valor, declara la variable NO como pública, pero al principio de todas las macros.

':)
'S aludos. D a n t e   A m o r . R ecuerda valorar la respuesta. G racias
':)

¿

Puedes escribirme a mi correo o darme el tuyo para pasarte el archivo y explicarte un poco mejor?