Shade Weekends in Calendar

Hi All,

I had some create calendar code brilliantly tidied up and sorted for me by xld, however I posted as solved before I realised I needed a final answer, hence this post.

I would like to add to the code to shade out Saturdays and Sundays in the range they appear in, so if E3 is a Sat and F3 is a Sun, their range E5:F12 is shaded out and so on through the month for each Sat or Sun as it occurs.

I have done some serious homework but just can't find the solution.

Can anyone help put in the code in the example below?

[vba]Sub CalBeta1(Optional InputDate As String)
Dim diff As Long
Dim mydays As Long
Dim myspread As Long
Dim my2spread As Long
Dim startday As Variant

Application.ScreenUpdating = False

startday = GetDate(InputDate)
If startday = "" Then Exit Sub
' Check if valid date but not the first of the month
' -- if so, reset StartDay to first day of month.
If Day(startday) <> 1 Then startday = startday - Day(startday) + 1

Call DayCalculations(startday, mydays, myspread, my2spread)

' BEGIN FORMATTING
' Clear area D3:AH12 including any previous calendar.
Range("D3:AH12").Clear

Call AddHeaders(startday, mydays, myspread)

Call AddBorders(Range("D3:AH12"))

With Range("D3:AH4").Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

Columns("D:AH").ColumnWidth = 3

Range("D5:AH12").ClearContents

' Resize window to show all of calendar (may have to be adjusted
' for video configuration).
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1

' Prevent going to error trap unless error found by exiting Sub here.
Range("A5").Select

Application.ScreenUpdating = True

MsgBox "New Monthly Calendar created", vbOKOnly + vbInformation, "Attendance"

Exit Sub

MyErrorTrap:
MsgBox "You may not have entered your Month and Year correctly." & Chr(13) & _
"Spell the Month correctly (or use 3 letter abbreviation)" & Chr(13) & _
"and 4 digits for the Year"
If InputBox("Type in Month and year for Calendar. [Format: January 2012] ") = "" Then Exit Sub
Resume
End Sub

Private Function GetDate(Optional InputDate As String) As Variant
Dim MyInput As Variant

If InputDate = "" Then

MyInput = InputBox("Type in Month and year for Calendar. [Must be in format: Jan 2012]")

If MyInput <> "" Then MyInput = DateValue(MyInput)

GetDate = MyInput
Else

GetDate = DateValue(InputDate)
End If
End Function

Private Function DayCalculations(ByVal Start As Variant, _
ByRef NumDays As Long, ByRef Spread As Long, ByRef Spread2 As Long) As Boolean
Dim curyear As Long
Dim curmonth As Long
Dim finalday As Date

' Set variables to identify the year and month as separate variables.
curyear = Year(Start)
curmonth = Month(Start)

' Set variable and calculate the first day of the next month.
finalday = DateSerial(curyear, curmonth + 1, 1)

' Calculate how many days in the given month
NumDays = Day(DateSerial(Year(Date), curmonth + 1, 1) - 1)
' Used to input data in the proper format. I.E. if I select column C, I have to -1, if I select column D I have to -2
Spread = NumDays - 1
Spread2 = NumDays - 2
End Function

Private Function AddHeaders(ByVal Start As Date, ByVal NumDays As Long, ByVal Spread As Long) As Boolean
' Prepare cell for Month and Year as fully spelled out.
' Center the title with appropriate formatting
With Range("D1")
.Value = "Attendance " '& Year(start)
.Font.FontStyle = "Arial"
.Font.Size = 12
.Font.Bold = True
.Font.Italic = False
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With

' Prep next row to display month and year
With Range("D2")
.Value = MonthName(Month(Start)) & Chr(32) & Year(Start)
.NumberFormat = "mmmm yyyy"
.Font.FontStyle = "Arial"
.Font.Size = 12
.Font.Bold = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With

' Begin AutoFill days
' need to do a column count and have loop run until column count is equal to mydays
With Range("D3")
.Value = Format(Start, "ddd")
.Font.Name = "Arial"
.Font.Size = 9
.Font.Bold = True
.AutoFill Destination:=.Resize(1, NumDays), Type:=xlFillDefault
End With

' Place a "1" in cell position of the first day of the chosen
' month based on DayofWeek.
Range("D4").Value = 1

Range("E4").Insert
With Range("E4")
.Formula = "=(D4+1)"
.AutoFill Destination:=.Resize(1, Spread), Type:=xlFillDefault
End With
End Function

Private Function AddBorders(rng As Range) As Boolean
'Format the Calendar Range
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
Call BorderStyle(rng, xlEdgeLeft)
Call BorderStyle(rng, xlEdgeTop)
Call BorderStyle(rng, xlEdgeRight)
Call BorderStyle(rng, xlEdgeBottom)
Call BorderStyle(rng, xlInsideVertical)
Call BorderStyle(rng, xlInsideHorizontal)
End With
End Function

Private Function BorderStyle(rng As Range, Border As XlBordersIndex) As Boolean
With rng
With .Borders(Border)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function[/vba]
With Thanks for any help

Craig

[VBA]Sub CalBeta1(Optional InputDate As String)
Dim diff As Long
Dim mydays As Long
Dim myspread As Long
Dim my2spread As Long
Dim startday As Variant

Application.ScreenUpdating = False

startday = GetDate(InputDate)
If startday = "" Then Exit Sub
' Check if valid date but not the first of the month
' -- if so, reset StartDay to first day of month.
If Day(startday) <> 1 Then startday = startday - Day(startday) + 1

Call DayCalculations(startday, mydays, myspread, my2spread)

' BEGIN FORMATTING
' Clear area D3:AH12 including any previous calendar.
Range("D3:AH12").Clear

Call AddHeaders(startday, mydays, myspread)

Call AddHighlights(Range("D3:AH12"))

Call AddBorders(Range("D3:AH12"))

With Range("D3:AH4").Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

Columns("D:AH").ColumnWidth = 3

Range("D5:AH12").ClearContents

' Resize window to show all of calendar (may have to be adjusted
' for video configuration).
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1

' Prevent going to error trap unless error found by exiting Sub here.
Range("A5").Select

Application.ScreenUpdating = True

MsgBox "New Monthly Calendar created", vbOKOnly + vbInformation, "Attendance"

Exit Sub

MyErrorTrap:
MsgBox "You may not have entered your Month and Year correctly." & Chr(13) & _
"Spell the Month correctly (or use 3 letter abbreviation)" & Chr(13) & _
"and 4 digits for the Year"
If InputBox("Type in Month and year for Calendar. [Format: January 2012] ") = "" Then Exit Sub
Resume
End Sub

Private Function GetDate(Optional InputDate As String) As Variant
Dim MyInput As Variant

If InputDate = "" Then

MyInput = InputBox("Type in Month and year for Calendar. [Must be in format: Jan 2012]")

If MyInput <> "" Then MyInput = DateValue(MyInput)

GetDate = MyInput
Else

GetDate = DateValue(InputDate)
End If
End Function

Private Function DayCalculations(ByVal Start As Variant, _
ByRef NumDays As Long, ByRef Spread As Long, ByRef Spread2 As Long) As Boolean
Dim curyear As Long
Dim curmonth As Long
Dim finalday As Date

' Set variables to identify the year and month as separate variables.
curyear = Year(Start)
curmonth = Month(Start)

' Set variable and calculate the first day of the next month.
finalday = DateSerial(curyear, curmonth + 1, 1)

' Calculate how many days in the given month
NumDays = Day(DateSerial(Year(Date), curmonth + 1, 1) - 1)
' Used to input data in the proper format. I.E. if I select column C, I have to -1, if I select column D I have to -2
Spread = NumDays - 1
Spread2 = NumDays - 2
End Function

Private Function AddHeaders(ByVal Start As Date, ByVal NumDays As Long, ByVal Spread As Long) As Boolean
' Prepare cell for Month and Year as fully spelled out.
' Center the title with appropriate formatting
With Range("D1")
.Value = "Attendance " '& Year(start)
.Font.FontStyle = "Arial"
.Font.Size = 12
.Font.Bold = True
.Font.Italic = False
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With

' Prep next row to display month and year
With Range("D2")
.Value = MonthName(Month(Start)) & Chr(32) & Year(Start)
.NumberFormat = "mmmm yyyy"
.Font.FontStyle = "Arial"
.Font.Size = 12
.Font.Bold = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With

' Begin AutoFill days
' need to do a column count and have loop run until column count is equal to mydays
With Range("D3")
.Value = Format(Start, "ddd")
.Font.Name = "Arial"
.Font.Size = 9
.Font.Bold = True
.AutoFill Destination:=.Resize(1, NumDays), Type:=xlFillDefault
End With

' Place a "1" in cell position of the first day of the chosen
' month based on DayofWeek.
Range("D4").Value = 1

Range("E4").Insert
With Range("E4")
.Formula = "=(D4+1)"
.AutoFill Destination:=.Resize(1, Spread), Type:=xlFillDefault
End With
End Function

Private Function AddHighlights(rng As Range) As Boolean
With rng

For i = .FormatConditions.Count To 1 Step -1

.FormatConditions(i).Delete
Next i

.FormatConditions.Add Type:=xlExpression, _
Formula1:="=AND(D$3<>"""",WEEKDAY(D$4+$D$2-1,2)>5)"
.FormatConditions(1).Interior.ColorIndex = 37
End With
End Function

Private Function AddBorders(rng As Range) As Boolean
'Format the Calendar Range
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
Call BorderStyle(rng, xlEdgeLeft)
Call BorderStyle(rng, xlEdgeTop)
Call BorderStyle(rng, xlEdgeRight)
Call BorderStyle(rng, xlEdgeBottom)
Call BorderStyle(rng, xlInsideVertical)
Call BorderStyle(rng, xlInsideHorizontal)
End With
End Function

Private Function BorderStyle(rng As Range, Border As XlBordersIndex) As Boolean
With rng
With .Borders(Border)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Function[/VBA]

xld,

Just Testing....reply shortly

Craig
Always Learning no matter what the age - otherwise whats the point!
:clap: :thumb

xld,

tested the code and it is formatting incorrectly....for example, no matter which month I create, the weekend shading doesn't find each Sat and / or Sun....it appears to be random...

Craig

It is working perfectly here, tested against your previously posted workbook. Have you changed the format/layout at all?

or
[vba]Sub snb()
Application.ScreenUpdating = False

Range("D3:AH4").Clear
startday = "01-" & InputBox("Type in Month and year for Calendar." & String(4, vbLf) & "Format: 01-2012")
If Not IsDate(startday) Then Exit Sub

sn = Evaluate("transpose(row(1:" & DateDiff("d", startday, DateAdd("m", 1, startday)) & "))")
st = Evaluate("transpose(text(datevalue(""" & startday & """)+row(1:" & UBound(sn) & ")-1,""ddd""))")

For j = 1 To UBound(sn)
If LCase(Left(st(j), 1)) = "s" Then c01 = c01 & "," & Cells(3, j + 3).Address
Next

Cells(1, 4).Resize(2) = Application.Transpose(Array("Attendance " & Year(startday), Format(startday, "'mmmm yyyy")))
Cells(3, 4).Resize(, UBound(sn)) = st
Cells(4, 4).Resize(, UBound(sn)) = sn
Range(Mid(c01, 2)).Interior.ColorIndex = 15

Application.ScreenUpdating = False
End Sub[/vba]

xld,

Apologies for late reply was called away yesterday:

Its still giving me random highlights...the only difference between the original code and yesterdays was the range was different, nothing else.

I have attached a revised copy of the Workbook which is highlighting as shown....why its not working for me I don't know.

snb:

Thanks for your contribution, it does highlight Sats and Suns but not in the range only the text.

Craig
Work: 2003
Home: 2007

Quote:

---

it does highlight Sats and Suns but not in the range only the text

---

The code is so simple that if you analyse it you will be able to adapt it to your wishes. Please consider my suggestions as suggestions to help you attain your goals, not as solutions.

Craig,

Just change this one function like so

[VBA]Private Function AddHighlights(rng As Range) As Boolean
With rng

.Cells(1, 1).Select

For i = .FormatConditions.Count To 1 Step -1

.FormatConditions(i).Delete
Next i

.FormatConditions.Add Type:=xlExpression, _
Formula1:="=AND(D$3<>"""",WEEKDAY(D$4+$D$2-1,2)>5)"
.FormatConditions(1).Interior.ColorIndex = 37
End With
End Function[/VBA]

or

replace

[VBA]Range(Mid(c01, 2)).Interior.ColorIndex = 15 [/VBA]

by

[VBA]
For Each ar In Range(Mid(c01, 2)).Areas
ar.Resize(10).Interior.ColorIndex = 15
Next

[/VBA]

xld, yet again your expertise has proven invaluable.....as a beginner attempting to progress to the next level the advice and help given by these forums will hopefully get me there one day.
Thank you so much, we have supermarket in the UK that uses the slogan: Every Little Helps: and how true with vba.

snb: Likewise with my sentiments, I am learning and learning and sometimes what can seem simple can be difficult to understand, but I am trying my best to not just use the code but undertand it and how it works correctly.

VBA can be annoying, frustrating and crazy but the most rewarding area of IT I have ever attempted, although late in my working years to vba (still got more to go yet!!), I love it and without people like you who give your time and knowledge to learners like me and point us in the right direction we (and sometimes our companies) could never progress.

Thanks Again.....:thumb

Craig
The more I learn the more I want to know.

What is your company Craig?

I am a Civil Servant now after spending many many years in another occupation....dare I say in a wide forum like this, but as much as the 'company' likes to do large projects, the localisation of projects is lost and the small Excel VBA beginner like myself is almost inundated with requests to make information work better - on top of the day job, as the Excel work is an adddition to my actual job, but as we all do....we fit it in: thats not a whinge as I love the challenge of finding the answer (albeit with experts on this forum).

Without boring you (i hope not) everyday someone asks for a project of some sort from the design of a form to more complex vba tasks and Excel is at the heart of this and having only come into VBA following a comment from a colleague who said 'You can't do that in Excel' the challenge was set....

Happy Days....just so glad I can programme in my limited way and get a smile now and again........... and thanks to reading my rant!! - trust me, my VBA days are in their infancy and I want to grow old with it :rotlaugh:

Craig

That is interesting. I would have thought, in my uninformed manner, that the Civil Service would be one place that did not allow localised projects like that. Glad to hear that they too are focussed on getting the job done.

Good to hear you are enjoying your VBA journey. I have been doing IT for more years than I care to mention , and although BI and SQL Server are my main interests, VBA has been an enjoyable diversion.