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
Reply With Quote
Solved: Shade Weekends in Calendar
