These are Modules in VBA to check the time and date and do an alarm.
'Moddule 1
'Create Row
Sub Button1_Click()
'Disable Screen Update
Application.ScreenUpdating = False
'Variable Declaration
Dim Rng As Range
Dim shtRng As Range
Dim WrkSht As Worksheet
Dim i As Integer
Dim from As String
Dim tohere As String
Dim val As Integer
'Variable Initialization
i = 1
Set WrkSht = Application.ActiveSheet
Set Rng = Selection
val = Rng.Row
from = "G" + Mid(str(val), 2)
tohere = "M" + Mid(str(val), 2)
Set shtRng = Range(from, tohere)
For Each Rng In shtRng
With WrkSht.CheckBoxes.Add(Left:=Rng.Left, Top:=Rng.Top, Width:=Rng.Width, Height:=Rng.Height).Select
With Selection
.Characters.Text = Rng.Value
.Caption = ""
.Caption = "Day " & i
i = i + 1
End With
End With
Next
i = 1
Set shtRng = Range("E" + Mid(str(val), 2))
For Each Rng In shtRng
With WrkSht.CheckBoxes.Add(Left:=Rng.Left, Top:=Rng.Top, Width:=Rng.Width, Height:=Rng.Height).Select
With Selection
.Characters.Text = Rng.Value
.Caption = ""
.Caption = "Alarm " & i
i = i + 1
End With
End With
Next
shtRng.ClearContents
shtRng.Select
'Enable Screen Update
Application.ScreenUpdating = True
End Sub
'Delete Row
Sub Button2_Click()
Dim from As String
Dim tohere As String
Dim val As Integer
Dim ws As Worksheet
Dim myRange As Range
Dim check As CheckBox
Set ws = Sheets("Sheet1")
Set Rng = Selection
val = Rng.Row
from = "E" + Mid(str(val), 2)
tohere = "M" + Mid(str(val), 2)
'OD Checkboxes
Set myRange = ws.Range(from, tohere)
For Each check In ws.CheckBoxes
If Not Intersect(check.TopLeftCell, myRange) Is Nothing Then
check.Delete
End If
Next
Range("A" + Mid(str(val), 2)).Clear
Range("A" + Mid(str(val), 2)).EntireRow.Delete
End Sub
'Module 2
Dim CountDown As Date
Sub Timer()
CountDown = Now + TimeValue("00:00:01")
Application.OnTime CountDown, "Reset"
End Sub
Sub Reset()
'On Error GoTo 10
Dim count As Range
Dim shtRng As Range
Dim Day As String
Dim txt As String
Dim prog As String
Dim addRng As String
Dim WrkBook As Workbook
Dim WrkSheet As Worksheet
WrBook = "RPClock.xlsm"
Set shtRng = Range("A5:A100")
For Each Rng In shtRng
Workbooks("RPClock.xlsm").Sheets("Sheet1").Range("A3").Value = Time()
10: If Rng.Value <> "" Then
Day = Format(Now(), "dddd")
If Range("A" + Mid(str(Rng.Row), 2)) = Range("A3").Value Then
If CheckDay(Rng.Row, Day) Then
Beep
txt = Range("D" + Mid(str(Rng.Row), 2)).Value
For Each cb In ActiveSheet.CheckBoxes
If cb.Value = 1 Then
addRng = ActiveSheet.Shapes(cb.Name).TopLeftCell.Address
If addRng = Range("E" + Mid(str(Rng.Row), 2)).Address Then
prog = "python3 C:Users
chrdDocumentsPythonPlaysounds.py ""Chimes2"" """ & txt & """"
Exit For
Else
prog = "python3 C:Users
chrdDocumentsPythonText2speech.py ""--lang=en"" """ & txt & """"
End If
End If
Next
Call Shell(prog, vbNormalFocus)
End If
End If
End If
Next
Call Timer
End Sub
Sub DisableTimer()
On Error Resume Next
Application.OnTime EarliestTime:=CountDown, Procedure:="Reset", Schedule:=False
End Sub
Function CheckDay(Rng As Integer, Day As String) As Boolean
Dim shtRng As Range
Dim addRng As String
Set shtRng = Range("G" + Mid(str(Rng), 2), "M" + Mid(str(Rng), 2))
On Error Resume Next
For Each cb In ActiveSheet.CheckBoxes
If cb.Value = 1 Then
addRng = ActiveSheet.Shapes(cb.Name).TopLeftCell.Address
Select Case addRng
Case Range("G" + Mid(str(Rng), 2)).Address
If Day = "Sunday" Then
CheckDay = True
Exit For
Else
CheckDay = False
End If
Case Range("H" + Mid(str(Rng), 2)).Address
If Day = "Monday" Then
CheckDay = True
Exit For
Else
CheckDay = False
End If
Case Range("I" + Mid(str(Rng), 2)).Address
If Day = "Tuesday" Then
CheckDay = True
Exit For
Else
CheckDay = False
End If
Case Range("J" + Mid(str(Rng), 2)).Address
If Day = "Wednesday" Then
CheckDay = True
Exit For
Else
CheckDay = False
End If
Case Range("K" + Mid(str(Rng), 2)).Address
If Day = "Thursday" Then
CheckDay = True
Exit For
Else
CheckDay = False
End If
Case Range("L" + Mid(str(Rng), 2)).Address
If Day = "Friday" Then
CheckDay = True
Exit For
Else
CheckDay = False
End If
Case Range("M" + Mid(str(Rng), 2)).Address
If Day = "Saturday" Then
CheckDay = True
Exit For
Else
CheckDay = False
End If
End Select
End If
Next
End Function