通過VBA在Excel創建可視化日歷

Question

我的程序做了我期望做的事情。 我對最后一個循環不滿意。

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

我已經有一個計數為 31 的循環，但如果我把它放在那里，它將執行 12 次。 有更聰明的方法嗎？

Answer 1

我會將值分配到一個數組中，然后寫入工作表 1 次，這樣應該會更快。 （讀取/寫入單元格是昂貴的操作）

然后對Sunday和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

嘗試將語句移到內部循環中並檢查i = 1是否只讓它執行一次。

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