Rotation Shift Calendar

[taze]

Where I work we have an on/off schedule of either 7/7, 14/14, 21/21 or 28/28 days. For years I have been creating new calendars and shading in the days we work. I found a Visual Basic code that can do the shading, but I can not get it to convert to the way I have the calendar laid out which is January, February & March at the top side by side with the other months following in order below. The visual basic code is made to run with the Months laid out as January & February at the top side by side with the other months following in order below. Can anyone help.

Dim CountRow, CountCol, CurMonth

Sub seven()
  Shade_Days 7
End Sub

Sub fourteen()
  Shade_Days 14
End Sub

Sub twentyone()
  Shade_Days 21
End Sub

Sub twentyeight()
  Shade_Days 28
End Sub

Sub hel()
MsgBox "Move the mouse pointer to select the date that" + _
crlf$ + "you wish to start highlighting the rota from." + _
crlf$ + "Then select the rota button 7, 14, 21 or 28. " + _
crlf$ + "Your rota will be highlighted from the point " + _
crlf$ + "of selection through to the end of the year. " + _
crlf$ + "" + _
crlf$ + "PeteHeff"
End Sub

Sub Clr()
CountRow = ActiveCell.Row
CountCol = ActiveCell.Column
Worksheets("Cal_mu3").Unprotect password:="MyPass"
Range("A2:O55").Select
With Selection.Interior
  .ColorIndex = 2
  .Pattern = xlSolid
  .PatternColorIndex = 2
End With
Cells(CountRow, CountCol).Select
Worksheets("Cal_mu3").Protect password:="MyPass"
End Sub

Sub Shade_Days(Days)
Dim DaysOn, WherAmI, EOYear
'get the cursor loc before clearing
CountRow = ActiveCell.Row
CountCol = ActiveCell.Column
If Check_ok = False Then
  MsgBox "The active cell must be on the numeric calander to function."
  Exit Sub
End If
If Val(Cells(CountRow, CountCol)) = 0 Then
  MsgBox "Make sure your start date is selected properly."
  Exit Sub
End If
Worksheets("Cal_mu3").Unprotect password:="MyPass"
Range("A2:O55").Select
With Selection.Interior
  .ColorIndex = 2
  .Pattern = xlSolid
  .PatternColorIndex = 2
End With
DaysOn = 0
EOYear = False
WherAmI = Wher(CountRow)
If CountCol < 8 Then
  'on the left
  CurMonth = WherAmI
Else
  'on the right
  CurMonth = WherAmI + 1
End If
'MsgBox CurMonth
Do While EOYear = False 'And tmp < 200
  If Cells(CountRow, CountCol) <> "" Then
  DaysOn = DaysOn + 1
  If DaysOn = (Days * 2) + 1 Then
    DaysOn = 1
  End If
    Cells(CountRow, CountCol).Select
    If DaysOn = Days + 1 Then
      Shade_HomeDay
    Else
      If DaysOn < Days + 1 Then
        Shade_ON
      End If
    End If
  End If
  FixNewPos
  If CurMonth = 13 Then EOYear = True
Loop
Worksheets("Cal_mu3").Protect password:="MyPass"
End Sub

Sub FixNewPos()
'MsgBox CurMonth Mod 2
Dim var1
If CurMonth Mod 2 = 0 Then
'rh side 2,4,6,8,10
  CountCol = CountCol + 1
  If CountCol = 16 Then
    CountCol = 9
    CountRow = CountRow + 1
    Select Case CurMonth
      Case 2
        var1 = 11
      Case 4
        var1 = 20
      Case 6
        var1 = 29
      Case 8
        var1 = 38
      Case 10
        var1 = 47
      Case 12
        var1 = 56
    End Select
    If CountRow = var1 Then
      'new month
      CurMonth = CurMonth + 1
      CountCol = 1
      CountRow = var1 + 3
     End If
   End If
Else
  CountCol = CountCol + 1
  If CountCol = 8 Then
    CountCol = 1
    CountRow = CountRow + 1
    Select Case CurMonth
      Case 1
        var1 = 11
      Case 3
        var1 = 20
      Case 5
        var1 = 29
      Case 7
        var1 = 38
      Case 9
        var1 = 47
      Case 11
        var1 = 56
    End Select
    If CountRow = var1 Then
      'new month
      CurMonth = CurMonth + 1
      CountCol = 9
      CountRow = var1 - 6
     End If
   End If
End If
End Sub

Function Wher(TR)
Select Case TR
  Case 5 To 10
    Wher = 1
  Case 14 To 19
    Wher = 3
  Case 23 To 28
    Wher = 5
  Case 32 To 37
    Wher = 7
  Case 41 To 46
    Wher = 9
  Case 50 To 55
    Wher = 11
End Select
End Function

Sub Shade_ON()
  With Selection.Interior
    .ColorIndex = 4
    .Pattern = xlSolid
    .PatternColorIndex = 2
  End With
End Sub
Sub Shade_HomeDay()
  With Selection.Interior
    .ColorIndex = 4
    .Pattern = xlGray25
    .PatternColorIndex = 3
  End With
End Sub
Function Check_ok()
Check_ok = False
If (CountCol > 0 And CountCol < 8) Or (CountCol > 8 And CountCol < 16) Then
  Select Case CountRow
    Case 5 To 10, 14 To 19, 23 To 28, 32 To 37, 41 To 46, 50 To 55
      Check_ok = True
  End Select
End If
End Function