通过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