Create patient schedule based on master therapist schedule

P

PapaBear

I have a friend who spends hours on scheduling and would like to streamline
things. She is a therapist who works with other therapists and their
patients. This is only for their Saturday schedule. They use a dry erase
board and magnets M-F, but the Saturday schedule needs to be different. This
is what the master sheet looks like:
OT1 OT2 PT1 PT2 Rec. ST1
7:00
7:30 Ann V. Carminia
8:00 Estela
8:30 Catherine Carminia
9:00 Renato Carminia
9:30 PW/Brk
10:00 Catherine
10:30 Estela Carminia
11:00 Chris
11:30 Chris
12:00
12:30 Ann V.
1:00 PW/Brk
1:30 Renato
2:00 PW/Brk
2:30 Carminia Carminia
3:00 PW/Brk
3:30 Floyd
4:00
There are usually 3 OT's, 3 PT's 3 ST's and a Tech and an Extra help person.
The master schedule is for each therapist (Occupational, Physical and
Speech).

What they want to be able to do is give the nurses each of the patients
schedules for the day. The names going down the time slots are the patients.
Normally each column would be filled with patient names, but for this
example I'm just using Carmenia. From this master list they want to be able
to generate a schedule for each patient. So, Carmenia's schedule would look
like this:
Carminia's Schedule:
7:30 - 8:00 ST
8:30 - 9:30 Rec
10:30 - 11:00 ST
2:30 - 3:00 PT/OT
Notice how the patient schedule only shows either OT, PT, ST or Rec. They
don't need to know if it's OT1, OT2 or OT3. If it's OT1, 2 or 3 they just
need to know it's OT. And if Carmenia's name appears in an OT and a PT cell
for the same time then it's a co-treatment, thus PT/OT from 2:30 to 3:00.

They'd like to generate this kind of schedule for each of their 20 or so
patients. I'm hoping there is a way to do this. Maybe Excel could create a
new sheet for each patient within the master sheet. Does anyone know how I
can make this happen?
 
D

Dave Peterson

I _think_ that this does what you want.

Option Explicit
Sub testme02()

Dim CurWks As Worksheet
Dim RptWks As Worksheet

Dim LastRow As Long
Dim LastCol As Long
Dim oRow As Long

Dim TableRng As Range
Dim myCell As Range
Dim myRow As Range
Dim myNames As Collection

Dim iCtr As Long
Dim jCtr As Long
Dim Swap1 As Variant
Dim Swap2 As Variant

Dim myCateHeader As String
Dim myCateStr As String
Dim myTimeStr As String
Dim NumInRow As Long

Application.ScreenUpdating = False

Set CurWks = Worksheets("Sheet1")
Set RptWks = Worksheets.Add
Set myNames = New Collection

With CurWks
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set TableRng = .Range("b2", .Cells(LastRow, LastCol))
End With

On Error Resume Next
For Each myCell In TableRng.Cells
If Trim(myCell.Value) = "" Then
'do nothing
Else
myNames.Add Item:=myCell.Value, key:=CStr(myCell.Value)
End If
Next myCell

For iCtr = 1 To myNames.Count - 1
For jCtr = iCtr + 1 To myNames.Count
If myNames(iCtr) > myNames(jCtr) Then
Swap1 = myNames(iCtr)
Swap2 = myNames(jCtr)
myNames.Add Swap1, Before:=jCtr
myNames.Add Swap2, Before:=iCtr
myNames.Remove iCtr + 1
myNames.Remove jCtr + 1
End If
Next jCtr
Next iCtr

oRow = -1
For iCtr = 1 To myNames.Count
oRow = oRow + 2
With RptWks.Cells(oRow, "A")
If oRow > 1 Then
.Parent.HPageBreaks.Add Before:=.Cells
End If
.Value = myNames(iCtr) & " Schedule:"
.Font.Bold = True
End With
oRow = oRow + 1

For Each myRow In TableRng.Rows
NumInRow = Application.CountIf(myRow, myNames(iCtr))
If NumInRow > 0 Then
myCateStr = ""
myTimeStr _
= Format(CurWks.Cells(myRow.Row, "A").Value, "hh:mm") _
& "-" & Format(CurWks.Cells(myRow.Row, "A").Value _
+ TimeSerial(0, 30, 0), "hh:mm")
For Each myCell In myRow.Cells
If myCell.Value = myNames(iCtr) Then
myCateHeader = CurWks.Cells(1, myCell.Column).Value
If IsNumeric(Right(myCateHeader, 1)) Then
myCateHeader _
= Left(myCateHeader, Len(myCateHeader) - 1)
End If
myCateStr = myCateStr & "/" & myCateHeader
End If
Next myCell
If myCateStr <> "" Then
myCateStr = Mid(myCateStr, 2)
End If
RptWks.Cells(oRow, "A").Value = myTimeStr
RptWks.Cells(oRow, "B").Value = myCateStr
oRow = oRow + 1
End If
Next myRow
Next iCtr

RptWks.UsedRange.Columns.AutoFit

Application.ScreenUpdating = True

End Sub

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
 
M

Max

Thought that was a great routine, Dave !

And for the OP / those interested ..
here's a demo file with the OP's set-up & Dave P's sub implemented:
http://cjoint.com/?klfBtLMmYZ
Schedule_Generation_Subroutine_by_Dave_Peterson_papabear_misc.xls
(Easier to see Dave's magic at work <g>)
 
R

Roger Govier

Hi Max

Thanks for taking the trouble to set that up, and post it for all of us
to see.
I watched the thread, but had no idea where to start.
When I saw Dave's code I naturally assumed it work!!!!
Nice one Dave!

Regards

Roger Govier
 
D

Dave Peterson

Well, it worked in Max's and my tests. But the proof of the pudding is in the
taste.

Roger said:
Hi Max

Thanks for taking the trouble to set that up, and post it for all of us
to see.
I watched the thread, but had no idea where to start.
When I saw Dave's code I naturally assumed it work!!!!
Nice one Dave!

Regards

Roger Govier
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro for creating a schedule 0
Calculate time worked based on start / end times & working hours 3
Macro to create a schedule 0
Automatically Adding Time based on a name ranged 1
need help with report and pretty much everything. 1
plot schedule-type data in graph, date and times as x & y axes 1
A challenge for an Excel Master... 9
Calculating Staffing on a Schedule 7

Top