Sub CreateMonthlyCalendar_Landscape()
Dim yearInput As Integer
Dim monthIndex As Integer
Dim mName As String
Dim firstDate As Date
Dim lastDate As Date
Dim tableRows As Integer, tableCols As Integer
Dim doc As Document
Dim calTable As Table
Dim r As Integer, c As Integer
Dim currentDate As Date
Dim weekendsColor As Long
Dim firstWeekday As Integer
Dim totalDays As Integer
Dim totalSlots As Integer
Dim numWeeks As Integer
' === SETTINGS ===
weekendsColor = RGB(220, 230, 241) ' Light blue weekend shading
tableCols = 7
' === ASK FOR YEAR ===
yearInput = InputBox("Enter the calendar year (e.g., 2025):", "Calendar Year", year(Date))
If Not IsNumeric(yearInput) Then Exit Sub
If yearInput < 1900 Or yearInput > 2100 Then
MsgBox "Please enter a valid year between 1900 and 2100."
Exit Sub
End If
Set doc = Documents.Add
With doc.PageSetup
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(0.8)
.BottomMargin = CentimetersToPoints(0.8)
.LeftMargin = CentimetersToPoints(0.8)
.RightMargin = CentimetersToPoints(0.8)
End With
' === LOOP THROUGH EACH MONTH ===
For monthIndex = 1 To 12
mName = monthName(monthIndex)
firstDate = DateSerial(yearInput, monthIndex, 1)
lastDate = DateSerial(yearInput, monthIndex + 1, 0)
' Page break between months
If monthIndex > 1 Then doc.Range(doc.Content.End - 1).InsertBreak Type:=wdPageBreak
' Month heading
doc.Range.InsertAfter vbCr
With doc.Paragraphs.Last.Range
.Text = mName & " " & yearInput
.Style = "Heading 1"
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.InsertParagraphAfter
End With
' Determine number of rows needed
firstWeekday = Weekday(firstDate, vbMonday)
totalDays = Day(lastDate)
totalSlots = (firstWeekday - 1) + totalDays
numWeeks = (totalSlots + 6) \ 7
tableRows = numWeeks + 1 ' +1 for header row
' Insert table
Set calTable = doc.Tables.Add(Range:=doc.Paragraphs.Last.Range, NumRows:=tableRows, NumColumns:=tableCols)
calTable.Borders.Enable = True
calTable.PreferredWidthType = wdPreferredWidthPercent
calTable.PreferredWidth = 100
' Header row (Mon–Sun)
Dim daysOfWeek As Variant
daysOfWeek = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
For c = 1 To tableCols
With calTable.Cell(1, c).Range
.Text = daysOfWeek(c - 1)
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Bold = True
End With
Next c
' Fill in dates
currentDate = firstDate
r = 2
c = firstWeekday
Do While currentDate <= lastDate
With calTable.Cell(r, c).Range
.Text = Day(currentDate)
.ParagraphFormat.Alignment = wdAlignParagraphRight
End With
' Shade weekends
If Weekday(currentDate, vbMonday) > 5 Then
calTable.Cell(r, c).Shading.BackgroundPatternColor = weekendsColor
End If
currentDate = currentDate + 1
c = c + 1
If c > 7 Then
c = 1
r = r + 1
End If
Loop
' === Adjust table appearance ===
On Error Resume Next
calTable.Rows.HeightRule = wdRowHeightExactly
' Smaller header row
calTable.Rows(1).Height = CentimetersToPoints(0.9)
' Slightly smaller date rows
For r = 2 To calTable.Rows.Count
calTable.Rows(r).Height = CentimetersToPoints(2.4)
Next r
' Column width for landscape fit
calTable.Columns.PreferredWidth = CentimetersToPoints(3.7)
On Error GoTo 0
' Reduce spacing around the table
calTable.Rows.SpaceBetweenColumns = 0
calTable.Range.ParagraphFormat.SpaceBefore = 0
calTable.Range.ParagraphFormat.SpaceAfter = 3
Next monthIndex
MsgBox "Compact landscape calendar created for " & yearInput & "!", vbInformation
End Sub
Sub AKCreateMonthlyCalendar()
Dim yearInput As Integer
Dim monthIndex As Integer
Dim mName As String
Dim firstDate As Date
Dim lastDate As Date
Dim dayNum As Integer
Dim weekdayNum As Integer
Dim tableRows As Integer
Dim tableCols As Integer
Dim doc As Document
Dim calTable As Table
Dim r As Integer, c As Integer
Dim currentDate As Date
Dim cellText As String
Dim weekendsColor As Long
Dim firstWeekday As Integer
Dim totalDays As Integer
Dim totalSlots As Integer
Dim numWeeks As Integer
' === SETTINGS ===
weekendsColor = RGB(220, 230, 241) ' Light blue highlight for weekends
tableCols = 7
' === ASK FOR YEAR ===
yearInput = InputBox("Enter the calendar year (e.g., 2025):", "Calendar Year", year(Date))
If Not IsNumeric(yearInput) Then
MsgBox "Please enter a valid year."
Exit Sub
End If
If yearInput < 1900 Or yearInput > 2100 Then
MsgBox "Please enter a valid year between 1900 and 2100."
Exit Sub
End If
Set doc = Documents.Add
doc.PageSetup.Orientation = wdOrientPortrait
' === LOOP THROUGH EACH MONTH ===
For monthIndex = 1 To 12
mName = monthName(monthIndex) ' use a different variable name so MonthName() isn't shadowed
firstDate = DateSerial(yearInput, monthIndex, 1)
lastDate = DateSerial(yearInput, monthIndex + 1, 0)
' Add a page break between months (except first)
If monthIndex > 1 Then
doc.Range(doc.Content.End - 1).InsertBreak Type:=wdPageBreak
End If
' Insert month heading
doc.Range.InsertAfter vbCr
With doc.Paragraphs.Last.Range
.Text = mName & " " & yearInput
.Style = "Heading 1"
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.InsertParagraphAfter
End With
' Calculate number of rows needed for date grid
firstWeekday = Weekday(firstDate, vbMonday) ' 1 = Monday ... 7 = Sunday
totalDays = Day(lastDate)
totalSlots = (firstWeekday - 1) + totalDays
numWeeks = (totalSlots + 6) \ 7 ' integer division rounding up
tableRows = numWeeks + 1 ' +1 for header row
' Insert table (header row + weeks rows)
Set calTable = doc.Tables.Add(Range:=doc.Paragraphs.Last.Range, NumRows:=tableRows, NumColumns:=tableCols)
calTable.Borders.Enable = True
calTable.PreferredWidthType = wdPreferredWidthPercent
calTable.PreferredWidth = 100
' Header row (Mon–Sun)
Dim daysOfWeek As Variant
daysOfWeek = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
For c = 1 To tableCols
With calTable.Cell(1, c).Range
.Text = daysOfWeek(c - 1)
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Bold = True
End With
Next c
' Fill in dates
currentDate = firstDate
r = 2
c = firstWeekday
Do While currentDate <= lastDate
cellText = CStr(Day(currentDate))
With calTable.Cell(r, c).Range
.Text = cellText
.ParagraphFormat.Alignment = wdAlignParagraphRight
.ParagraphFormat.SpaceAfter = 6
End With
' Highlight weekends (Saturday=6, Sunday=7 when Weekday(..., vbMonday))
If Weekday(currentDate, vbMonday) > 5 Then
calTable.Cell(r, c).Shading.BackgroundPatternColor = weekendsColor
End If
' Advance to next day
currentDate = currentDate + 1
c = c + 1
If c > 7 Then
c = 1
r = r + 1
End If
Loop
' Optional: make cells a reasonable size for notes
On Error Resume Next
calTable.Rows.HeightRule = wdRowHeightExactly
calTable.Rows.Height = CentimetersToPoints(2.6) ' adjust as desired
calTable.Columns.PreferredWidth = CentimetersToPoints(2.5)
On Error GoTo 0
calTable.Range.ParagraphFormat.SpaceBefore = 3
calTable.Range.ParagraphFormat.SpaceAfter = 3
Next monthIndex
MsgBox "Calendar created for " & yearInput & "!", vbInformation
End Sub
