Rotating duty roster

[Guest]

-- I operate the 10 week rotating roster as shown below. I need to be able
to perform 2 separate tasks the first of which is to enter a start date of
the week and then as each new week starts the names drop down 1 line and the
bottom name then goes back to the top of the roster.

The pay period is a 4 week cycle and so what I would also like to be able to
do is post each person their duties for the next 4 week cycle which would
automatically update when the new period’s start date is entered

Saturday Sunday Monday Tuesday Wednesday Thursday Friday
Duncan Rest A2 C2 A2 Rest C1 C1
Barbara C1 Rest Rest C2 C2 C2 C2
Rachel N2 Rest D1 D1 D1 D1 Rest
Latiffe A1 A1 C1 C1 C1 Rest Rest
Ali Rest Rest N2 N2 N2 N2 N2
Tony Rest C1 N1 N1 N1 Rest D1
Jorge N1 N1 Rest Rest A2 A2 A2
John A2 Rest NW NW Rest NW NW
Bryan Rest Rest A1 A1 A1 A1 A1
George Rest N2 A2 Rest NW N1 N1

Any help would be greatly appreciated.
Al

 

[Roger Govier]

Hi

With your first set of days appearing in cells B4:H4, and the subsequent
sets of day headings being on rows 16, 28 and 40.
In cell A1 enter the date of the start of the 4 week pay period e.g.
28/07/2007

In cell A4 enter
="W/C "&TEXT($A$1+(INT(ROW()/12)*7),"dd/mm/yy")
Copy this formula to cells A16, A28 and A40

This will ensure that each row of days has the appropriate W/C date
corresponding to the value you have entered in A1.

Copy the following event code and paste it into the Sheet module of the
relevant sheet from your workbook.
To do this, Mark the code>Control +C to copy>Right click on your sheet
tab>View Code>Control + V to paste the code into the sheet module.
Press Alt + F11 to return to your worksheet.

Copy your current (starting rota) to cells A5:H14

Now, enter the date again into cell A1, and as soon as you press Enter, the
rota will be copied down and adjusted.
Each time you change the value in cell A1, this will be repeated.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim n As Long, m As Long, o As Long, i As Long
n = 5: m = 14: o = 17

For i = 1 To 3
Range(Cells(m, 1), Cells(m, 8)).Select
Application.CutCopyMode = False
Selection.Cut
Cells(n, 1).Select
Selection.Insert Shift:=xlDown

Range(Cells(n, 1), Cells(m, 8)).Copy Cells(o, 1)
n = n + 12: m = m + 12: o = o + 12
Next i
Range(Cells(m, 1), Cells(m, 8)).Select
Application.CutCopyMode = False
Selection.Cut
Cells(n, 1).Select
Selection.Insert Shift:=xlDown
Application.ScreenUpdating = False
Application.EnableEvents = True
End Sub

 

[Guest]

Hi Roger
Thanks for your reply but there appears to be a snag in that although the
names move down a line each week so does the duty line move down as well so
that each person remains doing the same duties for each week. What needs to
happen is that either the names or the duties move down each week but not
both.
Thanks again for your help

 

[Roger Govier]

Hi Al

You know I realised that overnight, and had meant to post a revision this
morning, but completely forgot. Little point in moving both name and Roster.

The following amended code, still copies the main first block of roster
information down for the other three weeks (just in case you decide to amend
the roster itself), but the "shuffle, only takes place on column A for
Names.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim n As Long, m As Long, o As Long, i As Long
n = 5: m = 14: o = 17

For i = 1 To 3
Cells(m, 1).Select
Application.CutCopyMode = False
Selection.Cut
Cells(n, 1).Select
Selection.Insert Shift:=xlDown

Range(Cells(n, 1), Cells(m, 8)).Copy Cells(o, 1)
n = n + 12: m = m + 12: o = o + 12
Next i
Cells(m, 1).Select
Application.CutCopyMode = False
Selection.Cut
Cells(n, 1).Select
Selection.Insert Shift:=xlDown
Application.ScreenUpdating = False
Application.EnableEvents = True
End Sub


I hope this now resolves the problem.

 

[Guest]

Hi Roger
Thanks a million for that. It works a treat.

 

[Guest]

Hi again Roger
As an afterthought what changes would I have to make to apply it to a 5 week
rota?
Thanks again

 

[Roger Govier]

Hi

Just change the size of the loop from 3 to 4

For i = 1 To 3

For i = 1 To 4

 

[Guest]

Hi Roger
Sorry, I didn't explain what I meant properly. What I was wondering was what
changes to make if it was only a 5 man rota but to still show 4 weeks at a
time.
Thanks again

 

[Roger Govier]

Hi Al
For your 10 employee scenario
Initial setting
n = 5: m = 14: o = 17
each time through loop
n = n + 12: m = m + 12: o = o + 12

n is the starting row number, Employee 1
m is the last employee row number, Employee 10
o is the row number for the 1st Employee in the second week.

12 is the add-on each time (based upon 10 employees and 3 row interval 2
blank lines, 1 line of days)

so, for 5 employees change those 2 lines in the code to
n=5 : m=9 : o=12
n=n+7:m=m+7=o+7