Validate Appointment Times?
Here's what I have:
One master spreadsheet
One data entry spreadsheet - appointments are copied to the master
spreadsheet's next available row.
My program searches through each row to see if there is an appointment
conflict before the appointment is copied. I just can't seem to get it
to work though! It works if the dates or times are equal. For example,
if there is an existing appointment for 3:30 - 4:30 and I try to add
one for 4:00 - 5:00, the program will allow it (probably because my
code and/or logic is wrong). My code is as follows:
Sub UpdateMaster()
' Macro1 Macro
' Macro recorded 12/11/2003 by 787940
'
Dim r As Integer
Dim MyRow As Integer
Dim ApptDate As Date
Dim ApptStart As Date
Dim ApptEnd As Date
MyRow = ActiveCell.Row
ApptDate = Range("D" & MyRow).Value
ApptStart = Range("E" & MyRow).Value
ApptEnd = Range("F" & MyRow).Value
'MsgBox "Apptdate: " & ApptDate & " Apptstart: " & ApptStart & "
apptdur: " & ApptDur & " apptend: " & ApptEnd
'Exit Sub
Range("A" & MyRow & ":F" & MyRow).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Master").Select
r = 2
Dim CheckApptDate, CheckApptStart, CheckApptEnd As Date
Do
'Set the variables
CheckApptDate = Range("D" & r).Value
CheckApptStart = Range("E" & r).Value
CheckApptEnd = Range("F" & r).Value
'Check the appointment date
If ApptDate = CheckApptDate Then
'Check the start time
If ApptStart = CheckApptStart Then
MsgBox "This appointment time already exists. Please
select another time."
Application.CutCopyMode = False
Range("D" & r).Select
Exit Sub
Else
If ApptStart CheckApptStart And ApptEnd
CheckApptEnd Then
MsgBox "This appointment conflicts with another
appointment. Please select another time."
Application.CutCopyMode = False
Range("D" & r).Select
Exit Sub
End If
End If
Else
'do nothing
End If
r = r + 1
Loop Until Cells(r, 256).End(xlToLeft).Column = 1 And Cells(r, 1)
= ""
Cells(r, 1).Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
End Sub
Thanks in advance for your help!
Shelley
|