VBA学习(22)：动态显示日历

xwLink19962024-08-03 11:21

这是在ozgrid.com论坛上看到的一个贴子，很有意思，本来使用公式是可以很方便在工作表中实现日历显示的，但提问者因其需要，想使用VBA实现动态显示日历，即根据输入的年份和月份在工作表中显示日历。

下面是实现该效果的VBA程序，我稍微进行了一些调整和注释，供学习参考。

vbnet 复制代码 
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

作者其他作品：

VBA实战(Excel)(1)：提升运行速度

Ribbon第一节：控件大全

HTML实战(1)：新建一个HTML

VB.net实战(VSTO)：Excel插件的安装与卸载

相关推荐
warm3snow2 天前
AI 重塑产品管理工具：从 Jira 到智能体项目经理的终极演进
人工智能·ai·excel·项目管理·飞书·产品经理·jira·协同·tapd
LAM LAB13 天前
【VBA】Excel指定单元格范围内字体设置样式，处理导出课表单元格
excel·vba
在这habit之下13 天前
Keepalived学习总结
excel
Youngchatgpt13 天前
如何在 Excel 中使用 ChatGPT：自动化任务和编写公式
人工智能·chatgpt·自动化·excel
开开心心就好13 天前
安卓开源应用，超时提醒紧急人护独居安全
windows·决策树·计算机视觉·pdf·计算机外设·excel·动态规划
D_C_tyu13 天前
Vue3 + Element Plus | el-table 多级表头表格导出 Excel（含合并单元格、单元格居中）第二版
vue.js·elementui·excel
骆驼爱记录13 天前
WPS页码设置：第X页共Y-1页
自动化·word·excel·wps·新人首发
Cxiaomu14 天前
Python 文件解析： Excel / Word / PDF 的解析、处理、预览与下载
python·word·excel
2501_9307077814 天前
如何使用C#代码从 PDF 中提取表格并另存为Excel文件
pdf·excel
热门推荐
01GitHub 镜像站点02OpenClaw 使用和管理 MCP 完全指南03本地部署 OpenClaw + DeepSeek-R1 完全指南04OpenClaw 连接飞书完整指南：插件安装、配置与踩坑记录05OpenClaw 飞书机器人不回复消息？3 小时踩坑总结06Window 10部署openclaw报错node.exe : npm error code 12807OpenClaw 接入 QQ Bot 完整实践指南08OpenClaw macOS 完整安装与本地模型配置教程（实战版）09npm-error code 128问题解决方法10得物前端部门，没了