ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Validate Appointment Times? (https://www.excelbanter.com/excel-programming/285814-validate-appointment-times.html)

Shelley[_3_]

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


All times are GMT +1. The time now is 05:27 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com