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

已于 2024-08-03 09:02:45 修改
阅读量716 收藏 6
点赞数 12
分类专栏： VBA学习 文章标签： VBA Excel
于 2024-08-03 08:59:54 首次发布
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/nianfen/article/details/140884989
版权

 这是在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 

作者其他作品：

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

Ribbon第一节：控件大全

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

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

 

Access Vba中实现可自定制功能的漂亮日历(转自http://www.accessoft.com===>红尘如烟)
写代码容易,编程很难~
07-28 3134
modCalendar代码如下:Option Compare Database Option Explicit Private Type POINTAPI x As Long y As Long End Type Private Type RECT
vba日历作成工具
04-24
vba日历作成工具 可以生成1900到2100年的日历，农历，节气 其中节气和农历的算法参照网络上的思路，加以整理后完成的。有一些实用的价值但没有什么技术含量，追求完美的请绕路~
用excel vba写的日历代码
11-13
用excel vba写的日历部分代码如下 Private Sub Calendar(ByVal iyear, ByVal imonth) For icol = 1 To 7 For irow = 3 To 8 Cells(irow, icol) = "" Next Next iday = DateSerial(iyear, imonth, 1) '取得相应年月第一天的日期 irow = 3 icol = Weekday(iday) '计算该天是星期几 Do Cells(irow, icol) = Day(iday) '在单元格填入日期 If Weekday(iday) = vbSaturday Then '星期六则的换行 irow = irow + 1 icol = 1 Else icol = icol + 1 End If iday = DateAdd("d", 1, iday) '日期递增 Loop While (Day(iday)) <> 1 End Sub
一个简单的表格VBA日历窗体
05-02
一个简单的表格VBA日历窗体
VBA窗体日历插件
gitblog_09712的博客
10-15 300
VBA窗体日历插件 【下载地址】VBA窗体日历插件 本仓库提供了一款由VBA窗体制作的日历小插件，名为“VBA窗体日历插件.zip”。该插件可以直接导入并使用，方便用户在Excel中快速添加日历功能 项目地址: https://g...
VBA EXCEL制作日历控件
03-17
在EXCEL中，可以通过双击单元格，调出日历控件，通过对日历控件的操作，将所选日期更新到单元格中，该控件代码完全开放免费，供大家学习和使用，感兴趣的同学可以多多关注www.allmlp.com，让我们共同成长共同学习。
VBA 添加日历控件的操作
weixin_30443895的博客
05-17 4799
近几天需要做一个VBA的宏，以方便在excel中选择格式化后日期，要求添加日历控件，并按照格式化进行输出，由于是第一次接触VBA，因此查询了一些资料，下面对自己所做的过程进行一下总结： 1、首先新建一个excel文档。 2、对excel文档添加添加日历控件，具体过程如下图： 插入其他控件中的日历控件，如下图： 添加完后如下图所示： 双击控件即可编写代码...
使用VBA快速创建日历表（时间维度表）
神奇的BI
12-05 871
在数据统计分析中经常用到日历表，也有很多方法创建日历表，例如如下几篇博客分享如何使用Power Query创建日历表（相关链接参见本博文的最后部分）。 本次将要分享如何使用VBA创建如下格式的日历表，需要注意的是`周次`列，其中第x周的计算需要一些技巧。
VBA窗体日历插件.zip
10-26
一款VBA窗体制作的日历小插件，直接导入使用即可！
提升Excel效率的利器：VBA窗体日历插件
最新发布
gitblog_09793的博客
10-17 950
提升Excel效率的利器：VBA窗体日历插件 【下载地址】VBA窗体日历插件 本仓库提供了一款由VBA窗体制作的日历小插件，名为“VBA窗体日历插件.zip”。该插件可以直接导入并使用，方便用户在Excel中快速添加日历功能 项目...
VB_VBA日期选择控件
09-23
安装方法, 1. 将控件 MSCOMCT2.OCX 复制至windows\system\ (win98) 或 winnt\system32\ (win2000). 2. 运行 " REGSVR32 MSCOMCT2.OCX" 进行注册。 也可以直接双击运行Setup.bat批处理文件来进行。 在VB/VBA中添加控件，选择Microsoft Date and Time Picker Control,Version 6.0
EXCEL 日历控件
09-19
所有的Excel日历控件仅支持32位的office ，在64位office是不可用的，这一点请大家谨记，64位的 office是不可能注册成功 日历控件的 。我使用的是 win10 64位的系统 32位 的2016office ，资源里面有详细注册说明和使用连接。
VB写的日历小控件(日期选择) 源码免费放出.rar
07-09
VB 日历控件（选择日期挺不错），挺精简的一款VB日历，很容易就能嵌入到你的程序中，源码免费放出了，希望大家喜欢哦。
Excel VBA日期控件使用说明
12-24
Excel VBA日期控件使用说明
VBA窗体数字液晶时钟.xls
09-02
VBA窗体数字液晶时钟.xls，vba源码开放
VBA实现的年历
11-13
VBA实现的年历，工具->宏->宏->执行，输入年份，确定
Excel做的日历
02-01
这样的日历不仅能够显示公历日期，还可能包含了农历日期，以满足用户在不同场景下的需求。例如，中国的传统节日通常与农历相关，因此一个完善的Excel日历可能会包含对这些节日的标注和提醒。 在描述中提到的“可以...
VBA窗体学习系列，大家快来分享
08-08
1. **图片变换**：窗体学习--图片变换_OK.xls可能涉及如何在VBA窗体中动态改变图片。这可能包括加载新的图像文件、调整图片大小或位置，以及实现图片的动画效果。在VBA中，可以使用Shape对象来处理窗体上的图形元素...
VBA_ActiveX 控件.zip
04-10
除了Microsoft提供的标准ActiveX控件外，还有很多第三方开发者提供了各种各样的定制控件，以满足特定需求，如图表、按钮、日历、数据库连接等。 在VBA中使用ActiveX控件，首先要了解它们的基本属性、方法和事件。...
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

xwLink1996

你的鼓励将是我创作的最大动力

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付：¥1
获取中
扫码支付

您的余额不足，请更换扫码支付或充值

打赏作者

实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值