这是在ozgrid.com论坛上看到的一个贴子,很有意思,本来使用公式是可以很方便在工作表中实现日历显示的,但提问者因其需要,想使用VBA实现动态显示日历,即根据输入的年份和月份在工作表中显示日历。
下面是实现该效果的VBA程序,我稍微进行了一些调整和注释,供学习参考。
Sub CalendarMaker()Dim MyInput As StringDim StartDay As LongDim DayofWeek As LongDim CurYear As LongDim CurMonth As LongDim FinalDay As LongDim cellAs RangeDim RowCell As LongDim ColCell As LongDim x As Long' 如果之前存在日历,取消保护工作表以Sub CalendarMaker()Dim MyInput As StringDim StartDay As LongDim DayofWeek As LongDim CurYear As LongDim CurMonth As LongDim FinalDay As LongDim cell As RangeDim RowCell As LongDim ColCell As LongDim 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 ThenStartDay = 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 = 35End With' 准备A2:G2为星期标签并使其居中以及合适的字体和高度.With Range("A2:G2").ColumnWidth = 11.VerticalAlignment = xlCenter.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.Orientation = xlHorizontal.Font.Size = 12.Font.Bold = True.RowHeight = 20End 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 = 21End 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 DayofWeekCase 1Range("A3").Value = 1Case 2Range("B3").Value = 1Case 3Range("C3").Value = 1Case 4Range("D3").Value = 1Case 5Range("E3").Value = 1Case 6Range("F3").Value = 1Case 7Range("G3").Value = 1End Select' 遍历单元格区域A3:G8每个单元格在之前的单元格之上加"1".For Each cell In Range("A3:G8")RowCell = cell.RowColCell = cell.Column'如果"1"在第1列.If cell.Column = 1 And cell.Row = 3 Then' 如果当前单元格不在第1列.ElseIf cell.Column <> 1 ThenIf cell.Offset(0, -1).Value >= 1 Thencell.Value = cell.Offset(0, -1).Value + 1' 当该月的最后一天被输入则停止.If cell.Value > (FinalDay - StartDay) Thencell.Value = ""' 当日历有正确的天数显示则退出循环.Exit ForEnd IfEnd If' 如果当前单元格不在第3行且在第1列.ElseIf cell.Row > 3 And cell.Column = 1 Thencell.Value = cell.Offset(-1, 6).Value + 1' 当该月最后一天被输入则停止.If cell.Value > (FinalDay - StartDay) Thencell.Value = ""' 当日历有正确的天数显示则退出循环.Exit ForEnd IfEnd IfNext' 创建条目单元格, 将其格式化为居中, 文本换行及添加边框.For x = 0 To 5Range("A4").Offset(x * 2, 0).EntireRow.InsertWith Range("A4:G4").Offset(x * 2, 0).RowHeight = 65.HorizontalAlignment = xlCenter.VerticalAlignment = xlTop.WrapText = True.Font.Size = 10.Font.Bold = False' 解锁这些单元格,以便在工作表受保护之后可以输入文本..Locked = FalseEnd With' 在日期周围设置边框.With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlLeft).Weight = xlThick.ColorIndex = xlAutomaticEnd WithWith Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlRight).Weight = xlThick.ColorIndex = xlAutomaticEnd WithRange("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround Weight:=xlThick, ColorIndex:=xlAutomaticNextIf 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 = xlMaximizedActiveWindow.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 SubResume
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 ThenStartDay = 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 = 35End With' 准备A2:G2为星期标签并使其居中以及合适的字体和高度.With Range("A2:G2").ColumnWidth = 11.VerticalAlignment = xlCenter.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.Orientation = xlHorizontal.Font.Size = 12.Font.Bold= True.RowHeight = 20End 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 = 21End 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 DayofWeekCase 1Range("A3").Value = 1Case 2Range("B3").Value = 1Case 3Range("C3").Value = 1Case 4Range("D3").Value = 1Case 5Range("E3").Value = 1Case 6Range("F3").Value = 1Case 7Range("G3").Value = 1End Select' 遍历单元格区域A3:G8每个单元格在之前的单元格之上加"1".For Each cell In Range("A3:G8")RowCell = cell.RowColCell = cell.Column'如果"1"在第1列.If cell.Column = 1 And cell.Row = 3 Then' 如果当前单元格不在第1列.ElseIf cell.Column <> 1 ThenIf cell.Offset(0, -1).Value >= 1 Thencell.Value = cell.Offset(0, -1).Value + 1' 当该月的最后一天被输入则停止.If cell.Value > (FinalDay - StartDay) Thencell.Value = ""' 当日历有正确的天数显示则退出循环.Exit ForEnd IfEnd If' 如果当前单元格不在第3行且在第1列.ElseIf cell.Row > 3 And cell.Column =1 Thencell.Value = cell.Offset(-1, 6).Value + 1' 当该月最后一天被输入则停止.If cell.Value > (FinalDay - StartDay) Thencell.Value = ""' 当日历有正确的天数显示则退出循环.Exit ForEnd IfEnd IfNext' 创建条目单元格, 将其格式化为居中, 文本换行及添加边框.For x = 0To 5Range("A4").Offset(x * 2, 0).EntireRow.InsertWith Range("A4:G4").Offset(x * 2, 0).RowHeight = 65.HorizontalAlignment = xlCenter.VerticalAlignment = xlTop.WrapText = True.Font.Size = 10.Font.Bold = False' 解锁这些单元格,以便在工作表受保护之后可以输入文本..Locked = FalseEnd With' 在日期周围设置边框.With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlLeft).Weight = xlThick.ColorIndex = xlAutomaticEnd WithWith Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlRight).Weight = xlThick.ColorIndex = xlAutomaticEnd WithRange("A3").Offset(x * 2, 0).Resize(2, 7).BorderAroundWeight:=xlThick, ColorIndex:=xlAutomaticNextIf 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 = xlMaximizedActiveWindow.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 SubResume
End Sub
技术交流,软件开发,欢迎加xwlink1996
作者其他作品:
VBA实战(Excel)(1):提升运行速度
Ribbon第一节:控件大全
HTML实战(1):新建一个HTML
VB.net实战(VSTO):Excel插件的安装与卸载