Appointments Failing to Line up correctly when more than one Appt scheduled in a day

[BigDawg15]

I am editing the attached workbook for my needs however, if there is more than one appointment in a day the appointments do not lineup properly.
Worksheet Schedule show how they are lining up and worksheet Schedule (2) show how they should be.

I have been unable to determine what part of the code is causing this. Thank you in advance for any help.

BigDawg15

[Aussiebear]

BigDawg15, be a little kind to us and tell us which section of code is not working correctly. Attaching the workbook is great, but can you narrow it down a little more please?

[BigDawg15]

Sorry,

I believe it is in the Sched_Refresh macro in the Schedule_Macros module.

Thank you,

BigDawg15

[Aussiebear]

In this code?


Sub Sched_Refresh()
Dim LastRow As Long, LastResultRow As Long, ResultRow As Long, SchedRow As Long, SchedCol As Long
Dim CalRow As Long, CalCol As Long, StatusRow As Long, DayApptCount As Long, ApptNumb As Long
Dim StatusColor As String, ApptId As String, ContName As String, ApptStatus As String
Dim GrpString As String, GrpArr() As String
Dim ApptShp As Shape
Dim ApptDate As Date, ApptStart As Date, ApptEnd As Date
Dim ApptWidth As Double, ApptLeft As Double
Dim ApptDesc As String
Application.ScreenUpdating = False
'Clear all existing appt shapes from the schedule
For Each ApptShp In Schedule.Shapes
On Error Resume Next
If InStr(ApptShp.Name, "ApptItem") > 0 Then ApptShp.Delete 'Delete Appt Shape
On Error GoTo 0
Next ApptShp
With Appts
LastRow = .Range("A99999").End(xlUp).Row 'Last Row
If LastRow < 4 Then Exit Sub
.Range("S3:AB99999").ClearContents 'Clear Previous Result
.Range("A3:J" & LastRow).AdvancedFilter xlFilterCopy, CriteriaRange:=.Range("O2:P3"), CopyToRange:=.Range("S2:AB2"), Unique:=True
LastResultRow = .Range("S99999").End(xlUp).Row
If LastResultRow < 3 Then Exit Sub
If LastResultRow < 4 Then GoTo NoSort
With .Sort 'Sort Based On Appt Date & time
.SortFields.Clear
.SortFields.Add Key:=Appts.Range("V3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ''Sort By Appt Date
.SortFields.Add Key:=Appts.Range("W3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ''Sort By Appt Time
.SetRange Appts.Range("S3:AB" & LastResultRow)
.Apply
End With
NoSort:
For ResultRow = 3 To LastResultRow
ApptId = .Range("S" & ResultRow).Value 'Appt ID
ApptDate = .Range("V" & ResultRow).Value 'Appt Date
ApptStart = .Range("W" & ResultRow).Value 'Appt. Start
ApptEnd = .Range("X" & ResultRow).Value 'Appt. End
ContName = .Range("U" & ResultRow).Value 'Contact Name
ApptStatus = .Range("Z" & ResultRow).Value 'Appt Status
ApptDesc = .Range("AB" & ResultRow).Value 'Appt Desc
' On Error Resume Next
StatusRow = Admin.Range("Status").Find(ApptStatus, , xlValues, xlWhole).Row 'Get Status Row
On Error GoTo 0
If StatusRow <> 0 Then StatusColor = Admin.Range("G" & StatusRow).Interior.Color 'Add Cell Color into Variable
DayApptCount = Application.WorksheetFunction.CountIf([ApptDate_Results], ApptDate) 'Get # of Appts in a single day
If DayApptCount > 4 Then DayApptCount = 4 'Set Max Appts to a single day
If DayApptCount > 1 Then ApptNumb = ApptNumb + 1 Else ApptNumb = 1 'Track Appt Number
If ApptNumb = 1 Then
For CalRow = 4 To 34 Step 6
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
SchedRow = CalRow 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
GoTo CreateAppt
End If
Next CalCol
Next CalRow
Else
SchedRow = SchedRow + 1 'Increment Row on Same Day Appts
End If
CreateAppt:
If SchedRow = 0 Or SchedCol = 0 Then GoTo NextAppt
' Check if there's already an appointment scheduled at the same time
Dim ApptShape As Shape
For Each ApptShape In Schedule.Shapes
If InStr(ApptShape.Name, "ApptItem") > 0 And ApptShape.Top = Schedule.Cells(SchedRow + 1, SchedCol).Top + 24 And _
ApptShape.Left >= Schedule.Cells(SchedRow, SchedCol).Left + 2 And ApptShape.Left <= Schedule.Cells(SchedRow, SchedCol).Left + ApptWidth + 145 Then
' An appointment already exists at this time, so don't add the new appointment
GoTo NextAppt
End If
Next ApptShape
Schedule.Shapes("SampleApptShp").Duplicate.Name = "ApptItem" & ApptId
ApptWidth = Schedule.Cells(SchedRow, SchedCol).Width 'Set Appt Shape Width
ApptLeft = Schedule.Cells(SchedRow, SchedCol).Left 'Set Left Postion
With Schedule.Shapes("ApptItem" & ApptId)
.Left = ApptLeft + 2 'Set Left Postion
.Top = Schedule.Cells(SchedRow + 1, SchedCol).Top + 24
.Width = ApptWidth + 145 'Set Shape Width
.Height = 18
.TextFrame2.TextRange.Text = Format(ApptStart, "H:MMa/p") & "-" & Format(ApptEnd, "H:MMa/p") & " " & ContName & " " & ApptDesc
.OnAction = "Sched_Appt_Click"
If StatusRow <> 0 Then .Fill.ForeColor.RGB = StatusColor 'Add Fill Color
End With
NextAppt:
Next ResultRow
End With
ActiveWindow.Zoom = 75
Application.ScreenUpdating = True
End Sub


Sub Sched_Appt_Select()
Dim ApptId As Long, ApptRow As Long
ApptId = Replace(Application.Caller, Left(Application.Caller, 8), "")
Schedule.Range("B8").Value = ApptId
Appt_Load
End Sub

[BigDawg15]

Yes Sir that is the one. I've tried editing different points of the code but nothing seemed to correct the problem.

Thank you,

BigDawg15

[georgiboy]

The problem you are having is that you set the 'SchedRow' & 'SchedCol' inside the 'If ApptNumb = 1 Then' loop.

The issue with that is that the column (SchedCol) is only set for the first Appt and not looked at for any further Appt's, you incremented the 'SchedRow' in your code so it put the Appt's one under the other but in the same column.

Below is not a perfect fix but it should help you understand the issue and get the code doing what you want it to:

Sub Sched_Refresh()
Dim LastRow As Long, LastResultRow As Long, ResultRow As Long, SchedRow As Long, SchedCol As Long
Dim CalRow As Long, CalCol As Long, StatusRow As Long, DayApptCount As Long, ApptNumb As Long
Dim StatusColor As String, ApptId As String, ContName As String, ApptStatus As String
Dim GrpString As String, GrpArr() As String
Dim ApptShp As Shape
Dim ApptDate As Date, ApptStart As Date, ApptEnd As Date
Dim ApptWidth As Double, ApptLeft As Double
Dim ApptDesc As String
Dim ApptNumb2 As Long


Application.ScreenUpdating = False


'Clear all existing appt shapes from the schedule
For Each ApptShp In Schedule.Shapes
On Error Resume Next
If InStr(ApptShp.Name, "ApptItem") > 0 Then ApptShp.Delete 'Delete Appt Shape

On Error GoTo 0
Next ApptShp


With Appts
LastRow = .Range("A99999").End(xlUp).Row 'Last Row
If LastRow < 4 Then Exit Sub
.Range("S3:AB99999").ClearContents 'Clear Previous Result
.Range("A3:J" & LastRow).AdvancedFilter xlFilterCopy, CriteriaRange:=.Range("O2:P3"), CopyToRange:=.Range("S2:AB2"), Unique:=True
LastResultRow = .Range("S99999").End(xlUp).Row
If LastResultRow < 3 Then Exit Sub

If LastResultRow < 4 Then GoTo NoSort
With .Sort 'Sort Based On Appt Date & time
.SortFields.Clear
.SortFields.Add Key:=Appts.Range("V3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ''Sort By Appt Date
.SortFields.Add Key:=Appts.Range("W3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ''Sort By Appt Time
.SetRange Appts.Range("S3:AB" & LastResultRow)
.Apply
End With
NoSort:

For ResultRow = 3 To LastResultRow
ApptId = .Range("S" & ResultRow).Value 'Appt ID
ApptDate = .Range("V" & ResultRow).Value 'Appt Date
ApptStart = .Range("W" & ResultRow).Value 'Appt. Start
ApptEnd = .Range("X" & ResultRow).Value 'Appt. End
ContName = .Range("U" & ResultRow).Value 'Contact Name
ApptStatus = .Range("Z" & ResultRow).Value 'Appt Status
ApptDesc = .Range("AB" & ResultRow).Value 'Appt Desc

' On Error Resume Next

StatusRow = Admin.Range("Status").Find(ApptStatus, , xlValues, xlWhole).Row 'Get Status Row
On Error GoTo 0
If StatusRow <> 0 Then StatusColor = Admin.Range("G" & StatusRow).Interior.Color 'Add Cell Color into Variable
DayApptCount = Application.WorksheetFunction.CountIf([ApptDate_Results], ApptDate) 'Get # of Appts in a single day
If DayApptCount > 4 Then DayApptCount = 4 'Set Max Appts to a single day
If DayApptCount > 1 Then ApptNumb = ApptNumb + 1 Else ApptNumb = 1 'Track Appt Number


If ApptNumb = 1 Then
For CalRow = 4 To 34 Step 6
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
SchedRow = CalRow 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
GoTo CreateAppt
End If
Next CalCol
Next CalRow
Else
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
SchedRow = CalRow + ApptNumb2 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
ApptNumb2 = ApptNumb2 + 1
GoTo CreateAppt
End If
Next CalCol
End If

CreateAppt:
If SchedRow = 0 Or SchedCol = 0 Then GoTo NextAppt


' Check if there's already an appointment scheduled at the same time
Dim ApptShape As Shape
For Each ApptShape In Schedule.Shapes
If InStr(ApptShape.Name, "ApptItem") > 0 And ApptShape.Top = Schedule.Cells(SchedRow + 1, SchedCol).Top + 24 And _
ApptShape.Left >= Schedule.Cells(SchedRow, SchedCol).Left + 2 And ApptShape.Left <= Schedule.Cells(SchedRow, SchedCol).Left + ApptWidth + 145 Then
' An appointment already exists at this time, so don't add the new appointment
GoTo NextAppt
End If
Next ApptShape


Schedule.Shapes("SampleApptShp").Duplicate.Name = "ApptItem" & ApptId
ApptWidth = Schedule.Cells(SchedRow, SchedCol).Width 'Set Appt Shape Width
ApptLeft = Schedule.Cells(SchedRow, SchedCol).Left 'Set Left Postion


With Schedule.Shapes("ApptItem" & ApptId)
.Left = ApptLeft + 2 'Set Left Postion
.Top = Schedule.Cells(SchedRow + 1, SchedCol).Top + 24
.Width = ApptWidth + 145 'Set Shape Width
.Height = 18
.TextFrame2.TextRange.Text = Format(ApptStart, "H:MMa/p") & "-" & Format(ApptEnd, "H:MMa/p") & " " & ContName & " " & ApptDesc
.OnAction = "Sched_Appt_Click"
If StatusRow <> 0 Then .Fill.ForeColor.RGB = StatusColor 'Add Fill Color
End With

NextAppt:
Next ResultRow
End With
ActiveWindow.Zoom = 75


Application.ScreenUpdating = True
End Sub

[BigDawg15]

Thanks for that georgiboy. The explanation helps. Ill see what I can do with it.

Cheeers,

BigDawg15

[georgiboy]

Happy to help, let us know if you get stuck. The code above should work for you though.

[BigDawg15]

I am having trouble wrapping my head around getting the code to set 3 appointments in one day (the code was copied from another thread). It's working for two and from georgieboy's comments I believe this part of the code is what needs to be edited. Just not sure how.


If ApptNumb = 1 Then
For CalRow = 4 To 34 Step 6
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
SchedRow = CalRow 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
GoTo CreateAppt
End If
Next CalCol
Next CalRow
Else
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
SchedRow = CalRow + ApptNumb2 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
ApptNumb2 = ApptNumb2 + 1
GoTo CreateAppt
End If
Next CalCol
End If

CreateAppt:
If SchedRow = 0 Or SchedCol = 0 Then GoTo NextAppt
' Check if there's already an appointment scheduled at the same time
Dim ApptShape As Shape
For Each ApptShape In Schedule.Shapes
If InStr(ApptShape.Name, "ApptItem") > 0 And ApptShape.Top = Schedule.Cells(SchedRow + 1, SchedCol).Top + 24 And _
ApptShape.Left >= Schedule.Cells(SchedRow, SchedCol).Left + 2 And ApptShape.Left <= Schedule.Cells(SchedRow, SchedCol).Left + ApptWidth + 145 Then
' An appointment already exists at this time, so don't add the new appointment
GoTo NextAppt
End If
Next ApptShape


Cheers,

BigDawg15

[BigDawg15]

Ran gorgieboy's code again and it seems to be working properly.

Thank you,

BigDawg15

[georgiboy]

I think this bit:

If ApptNumb = 1 Then
For CalRow = 4 To 34 Step 6
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
SchedRow = CalRow 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
GoTo CreateAppt
End If
Next CalCol
Next CalRow
Else
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
SchedRow = CalRow + ApptNumb2 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
ApptNumb2 = ApptNumb2 + 1
GoTo CreateAppt
End If
Next CalCol
End If
Will be better as:

Dim tmp As Long
For CalRow = 4 To 34 Step 6
For CalCol = 7 To 20
If Schedule.Cells(CalRow, CalCol).Value = ApptDate Then
If CalRow + tmp = SchedRow And CalCol = SchedCol Then tmp = tmp + 1 Else tmp = 0
SchedRow = CalRow + tmp 'Set Row For Appt
SchedCol = CalCol 'Set Col For Appt.
GoTo CreateAppt
End If
Next CalCol
Next CalRow

[BigDawg15]

That works.

Thank you again.

BigDawg15