Create a visual calendar in Excel via VBA

Question

my program does what I expect to do. I'm not happy with the last loop.

Option Explicit
Public Sub calendar()
Dim i, j

Dim mDay As Date
For i = 1 To 12
    Cells(1, i + 1).Value = MonthName(i)
    For j = 2 To 32
        If IsDate(j - 1 & "/" & i & "/" & Year(Date)) Then
           mDay = CDate(j - 1 & "/" & i & "/" & Year(Date))
            Cells(j, i + 1).Value = mDay
            If Weekday(mDay) = 1 Then
                Cells(j, i + 1).Interior.Color = vbRed
                ElseIf Weekday(mDay) = 7 Then
                Cells(j, i + 1).Interior.Color = vbYellow
                Else
                Cells(j, i + 1).ClearFormats
            End If
                      Cells(j, i + 1).Value = Format(mDay, "DDDD")
                    
        End If
    Next j
Next I
For i = 1 To 31
    Cells(i + 1, 1).Value = i
Next i
End Sub

I already have a loop that counts to 31 but if I put it in there it would be executed 12 times. is there a smarter way to do it?

Answer 1

I will allocate the value into an array then write into the worksheet 1 time, should be faster that way. (Read/Write to/from cells are expensive operation)

Then use conditional formatting for Sunday and Saturday:

Public Sub calendar()
    Dim i As Long, j As Long

    Dim outputArr() As Variant
    ReDim outputArr(1 To 32, 1 To 13) As Variant

    For i = 1 To 12
        outputArr(1, i + 1) = MonthName(i)
        For j = 2 To 32
            If IsDate(j - 1 & "/" & i & "/" & Year(Date)) Then
                outputArr(j, i + 1) = Format(DateSerial(Year(Date), i, j - 1), "DDDD")
            End If
        Next j
    Next i
    
    For i = 1 To 31
        outputArr(i + 1, 1) = i
    Next i
    
    Dim calendarRng As Range
    Set calendarRng = Range("A1").Resize(32, 13)
    
    Dim formatSunday As FormatCondition
    Set formatSunday = calendarRng.FormatConditions.Add(xlCellValue, xlEqual, Formula1:="=" & Chr(34) & Format(Date - Weekday(Date, vbSunday) + 1, "DDDD") & Chr(34))
    formatSunday.Interior.Color = vbRed
    
    Dim formatSaturday As FormatCondition
    Set formatSaturday = calendarRng.FormatConditions.Add(xlCellValue, xlEqual, Formula1:="=" & Chr(34) & Format(Date - Weekday(Date, vbSaturday) + 1, "DDDD") & Chr(34))
    formatSaturday.Interior.Color = vbYellow
    
    calendarRng.Value = outputArr
End Sub

Answer 2

try to move the statement inside the inner loop and check for i = 1 to only let it execute once.

Option Explicit
Public Sub calendar()
Dim i, j

Dim mDay As Date
For i = 1 To 12
    Cells(1, i + 1).Value = MonthName(i)
    For j = 2 To 32
        If IsDate(j - 1 & "/" & i & "/" & Year(Date)) Then
           mDay = CDate(j - 1 & "/" & i & "/" & Year(Date))
            Cells(j, i + 1).Value = mDay
            If Weekday(mDay) = 1 Then
                Cells(j, i + 1).Interior.Color = vbRed
                ElseIf Weekday(mDay) = 7 Then
                Cells(j, i + 1).Interior.Color = vbYellow
                Else
                Cells(j, i + 1).ClearFormats
            End If
                      Cells(j, i + 1).Value = Format(mDay, "DDDD")
                    
        End If
        if i = 1 then cells(j ,1).value = j - 1
    Next j
Next I
'For i = 1 To 31
'    Cells(i + 1, 1).Value = i
'Next i
End Sub