Ripetere il suono finchè è presente il valore 1

Salve a tutti. Chiedo a voi un aiuto. Vorrei che il suono si ripeta con intervalli di 5 sec finchè nelle celle è presente valore 1. Grazie mille a chi mi può aiutare.
Questo è il codice che uso:

'=============>>
Option Explicit

'------------------->>
Private Declare Function PlaySound _
Lib "winmm.dll" _
Alias "PlaySoundA" _
(ByVal lpszName As String, _
ByVal hModule As Long, _
ByVal dwFlags As Long) As Long

'------------------->>
Public Sub Suono(sPath)
Const SND_ASYNC = &H1 ' Suona in modo asincrono
Const SND_FILENAME = &H20000 ' Nome e' il nome di un file

Call PlaySound(sPath, _
ByVal 0&, _
SND_FILENAME Or SND_ASYNC)
End Sub
'<<=============

'=============>>
Private Sub Worksheet_Calculate()
Dim Rng As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim rCell As Range
Dim myWav As String
Dim ok As Boolean

Const sStr As String = "1"
Const sPercorso As String = _
"C:\WINDOWS\Media\"
Const sWav As String = "Windows XP - Ripristino.WAV"
Const sWav2 As String = "alarm.WAV"

Set Rng = Range("f2:f18")
Set Rng2 = Range("g2:g18")

For Each rCell In Rng.Cells
' se c'è una variazione sulla colonna 'E' allora elabora la variazione
'If Target.Column = 5 Then
' se il valore della colonna 'AL ' è variato
If Not IsEmpty(rCell.Value) Then
If Not IsError(rCell.Value) Then
If rCell <> Rng2.Cells(rCell.Row - 1, 1) Then
' copia il nuovo valore nel vecchio
Rng2.Cells(rCell.Row - 1, 1) = rCell

' se il nuovo è 1 allora suona
If rCell = 1 Then
Call Suono(sPercorso & sWav2)
End If
End If

End If

End If


Next rCell

' If Not Rng2 Is Nothing Then
' For Each rCell In Rng2.Cells
' With rCell
' MsgBox (.Row)
' MsgBox (.Column)

' If Not IsEmpty(.Value) Then
' If Not IsError(.Value) Then
' If StrComp(rCell.Value, sStr, _
' vbTextCompare) = 0 Then
' ok = True
' Exit For
' Else
' ok = False
' End If
' End If
' End If
' End With
' Next rCell
'
' End If
End Sub