View Single Post
  #2   Report Post  
Dave Peterson
 
Posts: n/a
Default

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, Befo=jCtr
myNames.Add Swap2, Befo=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 Befo=.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

PapaBear wrote:

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?


--

Dave Peterson