阅读量:0
这是在ozgrid.com论坛上看到的一个贴子，很有意思，本来使用公式是可以很方便在工作表中实现日历显示的，但提问者因其需要，想使用VBA实现动态显示日历，即根据输入的年份和月份在工作表中显示日历。
下面是实现该效果的VBA程序，我稍微进行了一些调整和注释，供学习参考。
Sub CalendarMaker() Dim MyInput As String Dim StartDay As Long Dim DayofWeek As Long Dim CurYear As Long Dim CurMonth As Long Dim FinalDay As Long Dim cellAs Range Dim RowCell As Long Dim ColCell As Long Dim x As Long ' 如果之前存在日历,取消保护工作表以Sub CalendarMaker() Dim MyInput As String Dim StartDay As Long Dim DayofWeek As Long Dim CurYear As Long Dim CurMonth As Long Dim FinalDay As Long Dim cell As Range Dim RowCell As Long Dim ColCell As Long Dim x As Long ' 如果之前存在日历,取消保护工作表以避免错误. ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False '关闭屏幕刷新. Application.ScreenUpdating = False ' 设置错误捕捉. On Error GoTo MyErrorTrap ' 清除包括之前的日历的单元格区域A1:G14. Range("A1:G14").Clear ' 使用InputBox来获取想要显示的年和月份并赋给变量MyInput. MyInput = InputBox("输入要显示日历的年和月,例如2021-3,2021-3-25.") ' 允许用户使用输入框中的取消按钮结束宏. If MyInput = "" Then Exit Sub ' 获取输入的月初日期值. StartDay = DateValue(MyInput) ' 检查是否为有效日期但不是该月的第一天 ' -- 如果是, 重新设置StartDay为该月的第一天. If Day(StartDay) <> 1 Then StartDay = DateValue(Month(StartDay) & "/1/" & Year(StartDay)) End If ' 根据输入为月份和年份准备单元格. Range("A1").NumberFormat = "yyyy""年""m""月""" ' 跨A1:G1居中年份和月份标签并使用合适的字体和行高. With Range("A1:G1") .HorizontalAlignment = xlCenterAcrossSelection .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .RowHeight = 35 End With ' 准备A2:G2为星期标签并使其居中以及合适的字体和高度. With Range("A2:G2") .ColumnWidth = 11 .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = xlHorizontal .Font.Size = 12 .Font.Bold = True .RowHeight = 20 End With ' 在A2:G2中放置星期标签. Range("A2") = "星期日" Range("B2") = "星期一" Range("C2") = "星期二" Range("D2") = "星期三" Range("E2") = "星期四" Range("F2") = "星期五" Range("G2") = "星期六" ' 准备A3:G8为日期并使其居于右上角以及合适的字体和高度. With Range("A3:G8") .HorizontalAlignment = xlRight .VerticalAlignment = xlTop .Font.Size = 18 .Font.Bold = True .RowHeight = 21 End With ' 将输入的年份和月份完整拼写到"A1". Range("A1").Value = Application.Text(MyInput, "yyyy""年""m""月""") ' 设置变量并获取该月开始的星期几. DayofWeek = Weekday(StartDay) ' 设置变量来保存识别的年份和月份. CurYear = Year(StartDay) CurMonth = Month(StartDay) ' 设置变量来保存下月的第一天. FinalDay = DateSerial(CurYear, CurMonth + 1, 1) ' 基于DayofWeek为所选月的第一天的单元格位置输入"1". Select Case DayofWeek Case 1 Range("A3").Value = 1 Case 2 Range("B3").Value = 1 Case 3 Range("C3").Value = 1 Case 4 Range("D3").Value = 1 Case 5 Range("E3").Value = 1 Case 6 Range("F3").Value = 1 Case 7 Range("G3").Value = 1 End Select ' 遍历单元格区域A3:G8每个单元格在之前的单元格之上加"1". For Each cell In Range("A3:G8") RowCell = cell.Row ColCell = cell.Column '如果"1"在第1列. If cell.Column = 1 And cell.Row = 3 Then ' 如果当前单元格不在第1列. ElseIf cell.Column <> 1 Then If cell.Offset(0, -1).Value >= 1 Then cell.Value = cell.Offset(0, -1).Value + 1 ' 当该月的最后一天被输入则停止. If cell.Value > (FinalDay - StartDay) Then cell.Value = "" ' 当日历有正确的天数显示则退出循环. Exit For End If End If ' 如果当前单元格不在第3行且在第1列. ElseIf cell.Row > 3 And cell.Column = 1 Then cell.Value = cell.Offset(-1, 6).Value + 1 ' 当该月最后一天被输入则停止. If cell.Value > (FinalDay - StartDay) Then cell.Value = "" ' 当日历有正确的天数显示则退出循环. Exit For End If End If Next ' 创建条目单元格, 将其格式化为居中, 文本换行及添加边框. For x = 0 To 5 Range("A4").Offset(x * 2, 0).EntireRow.Insert With Range("A4:G4").Offset(x * 2, 0) .RowHeight = 65 .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .WrapText = True .Font.Size = 10 .Font.Bold = False ' 解锁这些单元格,以便在工作表受保护之后可以输入文本. .Locked = False End With ' 在日期周围设置边框. With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlLeft) .Weight = xlThick .ColorIndex = xlAutomatic End With With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlRight) .Weight = xlThick .ColorIndex = xlAutomatic End With Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround Weight:=xlThick, ColorIndex:=xlAutomatic Next If Range("A13").Value = "" Then Range("A13").Offset(0, 0).Resize(2, 8).EntireRow.Delete ' 关闭网格线显示. ActiveWindow.DisplayGridlines = False ' 保护工作表以避免覆盖日期. ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True ' 重新设置窗口大小显示所有日历. ActiveWindow.WindowState = xlMaximized ActiveWindow.ScrollRow = 1 ' 打开屏幕刷新. Application.ScreenUpdating = True ' 避免进入错误处理. Exit Sub ' 错误处理. MyErrorTrap: MsgBox "你可能没有正确地输入年份和月份." & Chr(13) & "正确地拼写月份" _ & " (或使用3字母缩写)" _ & Chr(13) & "年份使用4个数字." MyInput = InputBox("输入要显示日历的年和月,例如2021-3,2021-3-25.") If MyInput = "" Then Exit Sub Resume End Sub 避免错误. ActiveSheet.Protect DrawingObjects:=False, Contents:=False,Scenarios:=False '关闭屏幕刷新. Application.ScreenUpdating = False ' 设置错误捕捉. On Error GoTo MyErrorTrap ' 清除包括之前的日历的单元格区域A1:G14. Range("A1:G14").Clear ' 使用InputBox来获取想要显示的年和月份并赋给变量MyInput. MyInput =InputBox("输入要显示日历的年和月,例如2021-3,2021-3-25.") ' 允许用户使用输入框中的取消按钮结束宏. If MyInput = "" Then Exit Sub ' 获取输入的月初日期值. StartDay= DateValue(MyInput) ' 检查是否为有效日期但不是该月的第一天 ' -- 如果是, 重新设置StartDay为该月的第一天. If Day(StartDay) <> 1 Then StartDay = DateValue(Month(StartDay) & "/1/" &Year(StartDay)) End If ' 根据输入为月份和年份准备单元格. Range("A1").NumberFormat = "yyyy""年""m""月""" ' 跨A1:G1居中年份和月份标签并使用合适的字体和行高. With Range("A1:G1") .HorizontalAlignment = xlCenterAcrossSelection .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .RowHeight = 35 End With ' 准备A2:G2为星期标签并使其居中以及合适的字体和高度. With Range("A2:G2") .ColumnWidth = 11 .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = xlHorizontal .Font.Size = 12 .Font.Bold= True .RowHeight = 20 End With ' 在A2:G2中放置星期标签. Range("A2") = "星期日" Range("B2") = "星期一" Range("C2") = "星期二" Range("D2") = "星期三" Range("E2") = "星期四" Range("F2") = "星期五" Range("G2") = "星期六" ' 准备A3:G8为日期并使其居于右上角以及合适的字体和高度. With Range("A3:G8") .HorizontalAlignment = xlRight .VerticalAlignment = xlTop .Font.Size = 18 .Font.Bold = True .RowHeight = 21 End With ' 将输入的年份和月份完整拼写到"A1". Range("A1").Value= Application.Text(MyInput, "yyyy""年""m""月""") ' 设置变量并获取该月开始的星期几. DayofWeek= Weekday(StartDay) ' 设置变量来保存识别的年份和月份. CurYear =Year(StartDay) CurMonth= Month(StartDay) ' 设置变量来保存下月的第一天. FinalDay= DateSerial(CurYear, CurMonth + 1, 1) ' 基于DayofWeek为所选月的第一天的单元格位置输入"1". Select Case DayofWeek Case 1 Range("A3").Value = 1 Case 2 Range("B3").Value = 1 Case 3 Range("C3").Value = 1 Case 4 Range("D3").Value = 1 Case 5 Range("E3").Value = 1 Case 6 Range("F3").Value = 1 Case 7 Range("G3").Value = 1 End Select ' 遍历单元格区域A3:G8每个单元格在之前的单元格之上加"1". For Each cell In Range("A3:G8") RowCell = cell.Row ColCell = cell.Column '如果"1"在第1列. If cell.Column = 1 And cell.Row = 3 Then ' 如果当前单元格不在第1列. ElseIf cell.Column <> 1 Then If cell.Offset(0, -1).Value >= 1 Then cell.Value = cell.Offset(0, -1).Value + 1 ' 当该月的最后一天被输入则停止. If cell.Value > (FinalDay - StartDay) Then cell.Value = "" ' 当日历有正确的天数显示则退出循环. Exit For End If End If ' 如果当前单元格不在第3行且在第1列. ElseIf cell.Row > 3 And cell.Column =1 Then cell.Value = cell.Offset(-1, 6).Value + 1 ' 当该月最后一天被输入则停止. If cell.Value > (FinalDay - StartDay) Then cell.Value = "" ' 当日历有正确的天数显示则退出循环. Exit For End If End If Next ' 创建条目单元格, 将其格式化为居中, 文本换行及添加边框. For x = 0To 5 Range("A4").Offset(x * 2, 0).EntireRow.Insert With Range("A4:G4").Offset(x * 2, 0) .RowHeight = 65 .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop .WrapText = True .Font.Size = 10 .Font.Bold = False ' 解锁这些单元格,以便在工作表受保护之后可以输入文本. .Locked = False End With ' 在日期周围设置边框. With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlLeft) .Weight = xlThick .ColorIndex = xlAutomatic End With With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlRight) .Weight = xlThick .ColorIndex = xlAutomatic End With Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAroundWeight:=xlThick, ColorIndex:=xlAutomatic Next If Range("A13").Value = "" Then Range("A13").Offset(0, 0).Resize(2, 8).EntireRow.Delete ' 关闭网格线显示. ActiveWindow.DisplayGridlines = False ' 保护工作表以避免覆盖日期. ActiveSheet.Protect DrawingObjects:=True, Contents:=True,Scenarios:=True ' 重新设置窗口大小显示所有日历. ActiveWindow.WindowState = xlMaximized ActiveWindow.ScrollRow = 1 ' 打开屏幕刷新. Application.ScreenUpdating = True ' 避免进入错误处理. Exit Sub ' 错误处理. MyErrorTrap: MsgBox"你可能没有正确地输入年份和月份."_ &Chr(13) & "正确地拼写月份" _ &" (或使用3字母缩写)" _ &Chr(13) & "年份使用4个数字." MyInput =InputBox("输入要显示日历的年和月,例如2021-3,2021-3-25.") If MyInput = "" Then Exit Sub Resume End Sub技术交流，软件开发，欢迎加xwlink1996
