excel农历八字程序(excel制作农历日期)

这年头，Excel都可以DIY日历了，你不会还不知道吧

大家好，2022 年都已经过去 4 天了，大家去年的目标都完成了吗？

新的一年需要新的日历，最近我看到好多人在晒他们收到的新年日历。 然鹅，我没收到，不开心~

这时，坐在电脑前的我看到了 Excel，突然想到，我可以给自己做个日历啊，既能省钱，还能按照自己的心意 DIY！！！

如下图： 通过控件切换月份，日历中的日期，农历，以及休班状态自动更新！

是不是特别炫酷？

​

接下来，我就来揭开这份日历表的层层面纱。

首先我们要制作日历表的外观，在日历表中，每个格子是三行两列的，行格为 6，列格为 7。

E3 单元格为 2022，对应数字格式为 0 年，E4 单元格为 1，对应数字格式为 0 月。

​

事先准备好参数表。

▋插入控件

在【开发工具】选项卡下，点击【插入】-【数值调节钮】。

右键控件，选择【设置控件格式】。

​

设置对象窗口中，最小值为 1，最大值为 12，单元格链接为 F4。（月份为 1-12，所以最小值为 1，最大值为 12）

PS. 如果没有【开发工具】选项卡，在【文件】-【选项】-【自定义功能区】中调出。

基本的外观制作好后，下面就是编写公式啦。

如下图，在 E7 单元格中输入如下公式：

=DATE($E$3,$F$4,1)-WEEKDAY(DATE($E$3,$F$4,1),2)+INT(COLUMN(A:A)/2)+INT((ROW(1:1)-1)/3)*7</span></code>

如下图，在 F7 单元格中输入如下公式：

=IF(MONTH(E7)=$F$4,IFERROR(VLOOKUP(E7,参数表!$A:$D,4,0),""),"")

如下图，在 E8 单元格中输入如下公式：

=IF(MONTH(E7)=$F$4,IFERROR(VLOOKUP(E7,参数表!$A:$D,3,0),""),"")

最后填充公式就可以啦~ 如动图所示，选择 E7:F9，向右向下填充公式。

小 tips： E7 单元格函数公式：

=DATE($E$3,$F$4,1)-WEEKDAY(DATE($E$3,$F$4,1),2)+INT(COLUMN(A:A)/2)+INT((ROW(1:1)-1)/3)*7

其中前面一半公式是求：当前月 1 号上一个星期日的日期。

=DATE($E$3,$F$4,1)-WEEKDAY(DATE($E$3,$F$4,1),2)

后半段则是求：当前月 1 号上一个星期日的，也就是前半段公式得出的日期。 需要加上多少间隔数，才能得出当前单元格的日期。

=INT(COLUMN(A:A)/2)+INT((ROW(1:1)-1)/3)*7

比如说，2022 年 1 月 1 号，就是当前月 1 号前一个周日的日期（2021 年 12 月 26 号）+6。

​

F7 单元格函数公式：

=IF(MONTH(E7)=$F$4,IFERROR(VLOOKUP(E7,参数表!$A:$D,4,0),""),"")

如下图，如果是左边的日期是本月的日期，则使用 Vlookup 函数查找对应日期的对应休班状态，否则显示为空。

E8 单元格函数公式：

=IF(MONTH(E7)=$F$4,IFERROR(VLOOKUP(E7,参数表!$A:$D,3,0),""),"")

如果是上边的日期是本月的日期，则使用 vlookup 函数查找对应日期的对应日，否则显示为空。

公式设置完后，下一步就是要「装饰」日历表啦~

▋设置休班状态格式

❶ 让 0 不显示

填充完公式后，我们发现状态单元格中有很多 0，影响表格的美观程度，所以要让这些 0 都不显示。

这要怎么做呢？我们可以使用自定义数字格式。 按住【Ctrl】键，选中需要设置的单元格区域，再按住快捷键【Ctrl+1】弹出【设置单元格格式】对话框。

然后在类型中输入;;;@，单击【确定】按钮，此时除了文本，所有的 0 都显示为空白了。

小 Tips：在数字格式中，正数格式;负数格式;零值格式;文本格式。

;;;@ 其实就是就是让数值都不显示，文本显示本身，@ 符号代表文本本身的字符。 ❷ 设置休班颜色

将休字显示为红色，将班字显示为蓝色，这里我们可以使用条件格式。

在【开始】选项卡，单击【条件格式】，选择新建规则。

注意：活动单元格是 F7，就是下图中左边红框的位置（活动单元格指 Excel 表格中处于激活状态的单元格。可以是正在编辑的，也可以是选取的范围中的）。

选择【使用公式确定要设置格式的单元格】，输入为=F7="休"，格式设置为红色加粗字体，确定。

此时单元格中是「休」字的都显示为红色加粗字体。

同理，输入为=F7="班"，格式设置为蓝色加粗字体，确定。

此时单元格中是「班」字的都显示为蓝色加粗字体。

▋不在当前月份的日期不显示

如下图，我们可以看到，不在同个月份的日期依旧显示，这显然并不是我们想要的。

​

按住【Ctrl】键，选中指定区域，点击【条件格式】-【新建规则】。

选择【使用公式确定要设置格式的单元格】，输入：

=month(E7)ltgt$F$4

格式中字体设置为白色，单击【确定】按钮。

此时，我们所想要的效果就完成了，要想更美观的话，我们可以把农历单元格（如 Q8:R8 等）进行合并单元格操作。

你以为这就结束啦？当然还没有。

​

由于不同人的休假，还有调班时间不同，我们可以在参数表中对应位置选择好对应状态，日历表中就可以自动更新。

​

对于特殊日子，我们也可以在参数表中输入，比如某某日是你的生日，日历表中也会自动更新。

我们也可以在日历下面添加备注，如下图所示，然后就可以直接进行打印啦。

​

案例中的日历中使用的都是主题色，所以我们也可以通过更改主题色，变身成为另外的样子！

​

最后，总结一下： 本文介绍了日历表更高级的做法，具备农历加休班状态，公式自动更新的日历。

❶ 制作日历外观确定好日历所需要的行列数，根据自己的需求制作好外观。

❷ 设置公式日期数的确定：利用当前月的 1 号前一个星期日数来定位日期首个单元格。休班状态的查找：使用 vlookup 函数进行查找。农历的查找：使用 vlookup 函数进行查找。

❸ 设置格式针对休班状态出现的 0 值，我们可以使用数字格式将 0 值进行隐藏，文中我们使用的;;;@利用条件格式，将不属于当月的日期进行隐藏。

❹ 简单的进行延伸拓展由于本文的日历表是用公式制作的，所以比较灵活，我们可以根据自己的需求，再 DIY 制作属于自己的日历表。

当然啦，日历的玩法不局限这些，大家可以开开自己的脑洞，做出更多好玩的日历！！

​

最后我想说，2022 新年快乐鸭~对于新的一年大家有什么期待，或者对过去的 2021 有什么想说的，留言区可以与大家一起聊聊哦~

头条文章--Excel中带农历的万年历设计方法一

各位好，在前面有一期作品中，我们曾经在Excel中实现了万年历的制作，当时也有很多网友看过我的那期头条文章或头条视频，附带有评价和收藏，在此向你们表示感谢。

另外，有个名叫“斑斓虎zcy”的粉丝评论说我做的万年历如果含有农历就完美了，对这位粉丝的提议我欣然接受，另外，虽然我没采用“斑斓虎zcy”粉丝提供的公历转农历的关键技术模版，但对“斑斓虎zcy”粉丝的热心表示深深的谢意！

刚刚上一期，我为大家分享了自己弄的公历<---->农历互转的技术与方法，也有很多网友看了这期头条文章或视频，说明大家对这个方法也很认可的，谢谢各位啦！接下来，我准备用两种公历<---->农历互转的方法实现带农历的万年历设计吧！为了区分起见，我们暂定本期的题目为“头条文章--Excel中带农历的万年历设计方法一”、下期作品的题目为“头条文章--Excel中带农历的万年历设计方法二”。

本期，我们先来用第一种方法实现吧。

一、Excel前端带农历万年历界面设计

关于界面的设计，这里和上次那一期万年历的界面一样，这里不做过多描述，这里就只以截图直接呈现给各位吧。如下图所示

图1 带农历的万年历界面

二、用方法一实现带农历万年历的功能代码

模块1中代码如下：

'强势自定义“公历”<---->“农历”互转函数

'原创：互联网

'修正：今日头条号作者“跟我学Office高级办公应用” 2019/10/12

'---农历数据定义---

'先以 Hexadecimal_To_Binary 函数还原成长度为 18 的字符串，其定义如下：

'前12个字节代表1-12月：1为大月，0为小月；压缩成十六进制(1-3位)

'第13位为闰月的情况，1为大月30天，0为小月29天；(4位)

'第14位为闰月的月份，如果不是闰月为0，否则给出月份(5位)

'最后4位为当年农历新年的公历日期，如0131代表1月31日；当作数值转十六进制(6-7位)

'定义如下农历(阴历)日期常量(1899～2100，共202年，但是事实上我们只需要用到1900～2100这201年即可）

Private Const ylData = \"AB500D2,4BD0883,\" _

& \"4AE00DB,A5700D0,54D0581,D2600D8,D9500CC,655147D,56A00D5,9AD00CA,55D027A,4AE00D2,\" _

& \"A5B0682,A4D00DA,D2500CE,D25157E,B5500D6,56A00CC,ADA027B,95B00D3,49717C9,49B00DC,\" _

& \"A4B00D0,B4B0580,6A500D8,6D400CD,AB5147C,2B600D5,95700CA,52F027B,49700D2,6560682,\" _

& \"D4A00D9,EA500CE,6A9157E,5AD00D6,2B600CC,86E137C,92E00D3,C8D1783,C9500DB,D4A00D0,\" _

& \"D8A167F,B5500D7,56A00CD,A5B147D,25D00D5,92D00CA,D2B027A,A9500D2,B550781,6CA00D9,\" _

& \"B5500CE,535157F,4DA00D6,A5B00CB,457037C,52B00D4,A9A0883,E9500DA,6AA00D0,AEA0680,\" _

& \"AB500D7,4B600CD,AAE047D,A5700D5,52600CA,F260379,D9500D1,5B50782,56A00D9,96D00CE,\" _

& \"4DD057F,4AD00D7,A4D00CB,D4D047B,D2500D3,D550883,B5400DA,B6A00CF,95A1680,95B00D8,\" _

& \"49B00CD,A97047D,A4B00D5,B270ACA,6A500DC,6D400D1,AF40681,AB600D9,93700CE,4AF057F,\" _

& \"49700D7,64B00CC,74A037B,EA500D2,6B50883,5AC00DB,AB600CF,96D0580,92E00D8,C9600CD,\" _

& \"D95047C,D4A00D4,DA500C9,755027A,56A00D1,ABB0781,25D00DA,92D00CF,CAB057E,A9500D6,\" _

& \"B4A00CB,BAA047B,B5500D2,55D0983,4BA00DB,A5B00D0,5171680,52B00D8,A9300CD,795047D,\" _

& \"6AA00D4,AD500C9,5B5027A,4B600D2,96E0681,A4E00D9,D2600CE,EA6057E,D5300D5,5AA00CB,\" _

& \"76A037B,96D00D3,4AB0B83,4AD00DB,A4D00D0,D0B1680,D2500D7,D5200CC,DD4057C,B5A00D4,\" _

& \"56D00C9,55B027A,49B00D2,A570782,A4B00D9,AA500CE,B25157E,6D200D6,ADA00CA,4B6137B,\" _

& \"93700D3,49F08C9,49700DB,64B00D0,68A1680,EA500D7,6AA00CC,A6C147C,AAE00D4,92E00CA,\" _

& \"D2E0379,C9600D1,D550781,D4A00D9,DA400CD,5D5057E,56A00D6,A6C00CB,55D047B,52D00D3,\" _

& \"A9B0883,A9500DB,B4A00CF,B6A067F,AD500D7,55A00CD,ABA047C,A5A00D4,52B00CA,B27037A,\" _

& \"69300D1,7330781,6AA00D9,AD500CE,4B5157E,4B600D6,A5700CB,54E047C,D1600D2,E960882,\" _

& \"D5200DA,DAA00CF,6AA167F,56D00D7,4AE00CD,A9D047D,A2D00D4,D1500C9,F250279,D5200D1\"

'定义农历 (阴历)每月的汉字大写日期“天”

Private Const ylMd0 = \"初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五\" _

& \"十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十 \"

'定义农历 (阴历)一年中的汉字大写日期“月”

Private Const ylMn0 = \"正二三四五六七八九十冬腊\"

'定义农历 (阴历)年中的“天干”(如：甲乙丙丁......等)

Private Const ylTianGan0 = \"甲乙丙丁戊已庚辛壬癸\"

'定义农历 (阴历)年中的“地支”(如：子丑寅卯辰......等)

Private Const ylDiZhi0 = \"子丑寅卯辰巳午未申酉戌亥\"

'定义农历 (阴历)年中的“属相”(如：鼠牛虎兔龙......等)

Private Const ylShu0 = \"鼠牛虎兔龙蛇马羊猴鸡狗猪\"

Public shp_year_select As Shape, y '定义公有全局变量年份选择组合框shp_year_select和用于存储选择的年份变量y，以便所有的过程都可以调用和回传数据

Sub Run_Fill_Calender() '运行填充日历

[b4].Select

n = shp_year_select.ControlFormat.Value

y = shp_year_select.ControlFormat.List(n)

[O1] = y & \" 年历\" & \"[\" & Mid(GetYLDate(y & \"-6-1\"), 4, 6) & \"]\"

Fill_Calender_Datas '调用“填充日历数据”过程

[a65535] = y '将选择过的年份存储在单元格\"A65535\"中

End Sub

Sub Fill_Calender_Datas() '填充日历数据

Dim rg(1 To 12) As Range '定义12个元素的的范围区域对象数组

'为区域对象数组的每个区域对象元素对象指派这12个区域对象具体的实体

Set rg(1) = [b5:h10]: Set rg(2) = [j5:p10]: Set rg(3) = [r5:x10]: Set rg(4) = [z5:af10]

Set rg(5) = [b15:h20]: Set rg(6) = [j15:p20]: Set rg(7) = [r15:x20]: Set rg(8) = [z15:af20]

Set rg(9) = [b25:h30]: Set rg(10) = [j25:p30]: Set rg(11) = [r25:x30]: Set rg(12) = [z25:af30]

For i = 1 To 12

Select Case i

Case 1, 3, 5, 7, 8, 10, 12: days_31 y, i, rg(i)

Case 4, 6, 9, 11: days_30 y, i, rg(i)

Case 2: days_29_Or_28 y, i, rg(i)

End Select

Next

End Sub

Sub Erse_Calender_Datas() '清空日历数据

Dim rg As Range

Set rg = [5:10,15:20,25:30]

[b4].Select

rg.ClearContents

[O1] = \"---- 年历[-----年]\"

yr = Year(Date)

'以下是定位当今日期的年份在表单组合框中显示

For i = 1 To shp_year_select.ControlFormat.ListCount

If yr = Val(shp_year_select.ControlFormat.List(i)) Then

n = i

Exit For

End If

Next

shp_year_select.ControlFormat.ListIndex = n

End Sub

Sub days_31(y, m, r As Range) '月大--31天

Dim da As Date, d

r.ClearContents

week_str = \"日一二三四五六\"

d = 1

da = CDate(y & \"-\" & m & \"-\" & d) '将字符串动态转换为真正的日期

ws = Mid(Format(da, \"[$-804]aaaa\"), 3) '从转换为星期XX的字符串中提取大写星期几的汉字保存在ws中

First_Day_Pos_In_Week_Area = InStr(week_str, ws) '每月初始的1号在日历星期区域的定位位置

For d = 1 To 31

da = CDate(y & \"-\" & m & \"-\" & d) '将字符串动态转换为真正的日期

ws = Mid(Format(da, \"[$-804]aaaa\"), 3) '从转换为星期XX的字符串中提取大写星期几的汉字保存在ws中

Other_Day_Pos_In_Week_Area = InStr(week_str, ws)

'实际的每月的号数应该加上每月初始的1号在日历星期区域的定位位置减去1“”d + (First_Day_Pos_In_Week_Area - 1)，为了在第7个位置仍然将该号 _

数放在该行，所以还得再减去1“d + (First_Day_Pos_In_Week_Area - 1) - 1”，然后再除7取整，同时乘以7后加上该号数在日历中星期区域的实际列数 _

位置，即可得到该号数在日历区域的设计位置

p = Int((d + (First_Day_Pos_In_Week_Area - 1) - 1) / 7) * 7 + Other_Day_Pos_In_Week_Area

yl_md = Right(GetYLDate(da), 4) '调用转农历(阴历)函数，取后四个汉字月日日期字符

yl_m = Left(yl_md, 2) '拆解阴历月日中的月份

yl_d = Right(yl_md, 2) '拆解阴历月日中的日子

If yl_d = \"初一\" Then yl_d = yl_m '若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子

r(p) = d & Chr(10) & yl_d '将公历日期和对应的农历日期合在一起填入到p处正确位置

If da = Date Then r(p).Select '若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态

Next

End Sub

Sub days_30(y, m, r As Range) '月小--30天

Dim da As Date, d

r.ClearContents

week_str = \"日一二三四五六\"

d = 1

da = CDate(y & \"-\" & m & \"-\" & d) '将字符串动态转换为真正的日期

ws = Mid(Format(da, \"[$-804]aaaa\"), 3) '从转换为星期XX的字符串中提取大写星期几的汉字保存在ws中

First_Day_Pos_In_Week_Area = InStr(week_str, ws) '每月初始的1号在日历星期区域的定位位置

For d = 1 To 30

da = CDate(y & \"-\" & m & \"-\" & d) '将字符串动态转换为真正的日期

ws = Mid(Format(da, \"[$-804]aaaa\"), 3) '从转换为星期XX的字符串中提取大写星期几的汉字保存在ws中

Other_Day_Pos_In_Week_Area = InStr(week_str, ws)

'实际的每月的号数应该加上每月初始的1号在日历星期区域的定位位置减去1“”d + (First_Day_Pos_In_Week_Area - 1)，为了在第7个位置仍然将该号 _

数放在该行，所以还得再减去1“d + (First_Day_Pos_In_Week_Area - 1) - 1”，然后再除7取整，同时乘以7后加上该号数在日历中星期区域的实际列数 _

位置，即可得到该号数在日历区域的设计位置

p = Int((d + (First_Day_Pos_In_Week_Area - 1) - 1) / 7) * 7 + Other_Day_Pos_In_Week_Area

yl_md = Right(GetYLDate(da), 4) '调用转农历(阴历)函数，取后四个汉字月日日期字符

yl_m = Left(yl_md, 2) '拆解阴历月日中的月份

yl_d = Right(yl_md, 2) '拆解阴历月日中的日子

If yl_d = \"初一\" Then yl_d = yl_m '若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子

r(p) = d & Chr(10) & yl_d '将公历日期和对应的农历日期合在一起填入到p处正确位置

If da = Date Then r(p).Select '若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态

Next

End Sub

Sub days_29_Or_28(y, m, r As Range) '闰年2月份29天，平年2月份28天(例如2020年就是闰年)

Dim da As Date, d

r.ClearContents

week_str = \"日一二三四五六\"

d = 1

da = CDate(y & \"-\" & m & \"-\" & d) '将字符串动态转换为真正的日期

ws = Mid(Format(da, \"[$-804]aaaa\"), 3) '从转换为星期XX的字符串中提取大写星期几的汉字保存在ws中

First_Day_Pos_In_Week_Area = InStr(week_str, ws) '每月初始的1号在日历星期区域的定位位置

If Is_LeepYear(y) Then '闰年2月份天数

For d = 1 To 29

da = CDate(y & \"-\" & m & \"-\" & d) '将字符串动态转换为真正的日期

ws = Mid(Format(da, \"[$-804]aaaa\"), 3) '从转换为星期XX的字符串中提取大写星期几的汉字保存在ws中

Other_Day_Pos_In_Week_Area = InStr(week_str, ws)

'实际的每月的号数应该加上每月初始的1号在日历星期区域的定位位置减去1“”d + (First_Day_Pos_In_Week_Area - 1)，为了在第7个位置仍然将该 _

号数放在该行，所以还得再减去1“d + (First_Day_Pos_In_Week_Area - 1) - 1”，然后再除7取整，同时乘以7后加上该号数在日历中星期区域的实 _

际列数位置，即可得到该号数在日历区域的设计位置

p = Int((d + (First_Day_Pos_In_Week_Area - 1) - 1) / 7) * 7 + Other_Day_Pos_In_Week_Area

yl_md = Right(GetYLDate(da), 4) '调用转农历(阴历)函数，取后四个汉字月日日期字符

yl_m = Left(yl_md, 2) '拆解阴历月日中的月份

yl_d = Right(yl_md, 2) '拆解阴历月日中的日子

If yl_d = \"初一\" Then yl_d = yl_m '若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子

r(p) = d & Chr(10) & yl_d '将公历日期和对应的农历日期合在一起填入到p处正确位置

If da = Date Then r(p).Select '若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态

Next

Else '平年2月份天数

For d = 1 To 28

da = CDate(y & \"-\" & m & \"-\" & d) '将字符串动态转换为真正的日期

ws = Mid(Format(da, \"[$-804]aaaa\"), 3) '从转换为星期XX的字符串中提取大写星期几的汉字保存在ws中

Other_Day_Pos_In_Week_Area = InStr(week_str, ws)

'实际的每月的号数应该加上每月初始的1号在日历星期区域的定位位置减去1“”d + (First_Day_Pos_In_Week_Area - 1)，为了在第7个位置仍然将该 _

号数放在该行，所以还得再减去1“d + (First_Day_Pos_In_Week_Area - 1) - 1”，然后再除7取整，同时乘以7后加上该号数在日历中星期区域的实 _

际列数位置，即可得到该号数在日历区域的设计位置

p = Int((d + (First_Day_Pos_In_Week_Area - 1) - 1) / 7) * 7 + Other_Day_Pos_In_Week_Area

yl_md = Right(GetYLDate(da), 4) '调用转农历(阴历)函数，取后四个汉字月日日期字符

yl_m = Left(yl_md, 2) '拆解阴历月日中的月份

yl_d = Right(yl_md, 2) '拆解阴历月日中的日子

If yl_d = \"初一\" Then yl_d = yl_m '若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子

r(p) = d & Chr(10) & yl_d '将公历日期和对应的农历日期合在一起填入到p处正确位置

If da = Date Then r(p).Select '若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态

Next

End If

End Sub

Function Is_LeepYear(y) As Boolean '给定的年份是否为闰年LeepYear的判断

If (y Mod 400 = 0) Or (y Mod 100 <> 0 And y Mod 4 = 0) Then

Is_LeepYear = True

Else

Is_LeepYear = False

End If

End Function

'自定义“公历转农历”日期函数

Function GetYLDate(ByVal strDate As String) As String

On Error GoTo ExitFunction_Label

If Not IsDate(strDate) Then Exit Function '如果参数strDate非日期的无效字符串，则退出本函数工作

'定义setDate--设置的未来日期，tYear--未来日期的本年份，tMonth--本月份，tDay--本日子

Dim setDate As Date, tYear As Integer, tMonth As Integer, tDay As Integer

setDate = CDate(strDate) '为该GetYLDate()函数参数的字符串转换后的日期赋予设定的日期

tYear = Year(setDate): tMonth = Month(setDate): tDay = Day(setDate) '年、月、日分别取值

'如果不是有效有日期，退出

If tYear > 2100 Or tYear < 1900 Then Exit Function

'定义daList()--是元素为18位日期二进制字符串数组，conDate--农历新年日期，thisMonths--本年的二进制 _

月份信息(可能包含闰月)

Dim daList() As String * 18, conDate As Date, thisMonths As String

'定义AddYear--是相对1900年递增的年，AddMonth--月份增量，AddDay--天数增量，getDay--农历新年和设 _

之日期相差天数

Dim AddYear As Integer, AddMonth As Integer, AddDay As Integer, getDay As Integer

'定义YLyear--农历(阴历)年的字符串，YLShuXing--农历(阴历)年的属相

Dim YLyear As String, YLShuXing As String

'定义dd0--农历(阴历)年的阴历日子，mm0--农历(阴历)年的阴历月，ganzhi()--每个元素为2个字符的天干地 _

支数组

Dim dd0 As String, mm0 As String, ganzhi(0 To 59) As String * 2

'定义RunYue--农历(阴历)年是否闰月的布尔型标志，RunYue1--农历(阴历)年闰月月份

Dim RunYue As Boolean, RunYue1 As Integer, mDays As Integer, i As Integer

'加载2年内的农历数据

ReDim daList(tYear - 1 To tYear)

daList(tYear - 1) = Hexadecimal_To_Binary(Mid(ylData, (tYear - 1900) * 8 + 1, 7))

daList(tYear) = Hexadecimal_To_Binary(Mid(ylData, (tYear - 1900 + 1) * 8 + 1, 7))

AddYear = tYear

initYL:

AddMonth = CInt(Mid(daList(AddYear), 15, 2))

AddDay = CInt(Mid(daList(AddYear), 17, 2))

conDate = DateSerial(AddYear, AddMonth, AddDay) '农历新年日期

getDay = DateDiff(\"d\", conDate, setDate) + 1 '相差天数

If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL

thisMonths = Left(daList(AddYear), 14) '前14位为本年的二进制月份信息(可能有闰月)存于thisMonths中

RunYue1 = Val(\"&H\" & Right(thisMonths, 1)) '闰月月份

If RunYue1 > 0 Then '如果有闰月，则立即修正本年的二进制月份信息thisMonths，形成真正有效的二进制序 _

列信息

thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)

End If

thisMonths = Left(thisMonths, 13) '最后一次修正本年的二进制月份信息thisMonths，直接取13个月的情况

For i = 1 To 13 '遍历1～13个月，找到并计算含闰月的有效天数，同时退出循环

mDays = 29 + CInt(Mid(thisMonths, i, 1))

If getDay > mDays Then

getDay = getDay - mDays

Else

If RunYue1 > 0 Then '如果有闰月，则进一步根据i的值情况做如下处理

If i = RunYue1 + 1 Then RunYue = True '若i确系为闰月，则将闰月标志置为真

If i > RunYue1 Then i = i - 1 '若i大于闰月月份，则将将i回退修正

End If

AddMonth = i '最终记录下i作为真正的增量月份存入AddMonth

AddDay = getDay '同时，将得到的天数差作为增量天数

Exit For

End If

Next

dd0 = Mid(ylMd0, (AddDay - 1) * 2 + 1, 2) '用查找表的形式定位当前日期对应的农历(阴历)日子

mm0 = Mid(ylMn0, AddMonth, 1) + \"月\" '用查找表的形式定位当前日期对应的农历(阴历)月份

For i = 0 To 59 '0～59表示60年一个甲子，表示以60年一个轮回的形式，通过查找表精准定位每年的天干地支

ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1)

Next

YLyear = ganzhi((AddYear - 4) Mod 60) '通过查找表形式得出阴历年的天干地支表示形式

YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12) + 1, 1) '通过查找表形式得出阴历年的属相表示形式

If RunYue Then mm0 = \"闰\" & mm0 '如果某阴历月份有闰月，特别加上“闰X月”的形式

GetYLDate = \"农历：\" & YLyear & \"(\" & YLShuXing & \")年\" & mm0 & dd0 '拼接当前日期的完整农历信息

ExitFunction_Label:

End Function

'将压缩的阴历字符还原

Private Function Hexadecimal_To_Binary(ByVal strHex As String) As String '十六进制转二进制

Dim i As Integer, i1 As Integer, tmpV As String

Const hStr = \"0123456789ABCDEF\"

Const bStr = \"0000000100100011010001010110011110001001101010111100110111101111\"

tmpV = UCase(Left(strHex, 3))

'以下是十六进制转二进制的具体操作

For i = 1 To Len(tmpV)

i1 = InStr(hStr, Mid(tmpV, i, 1))

Hexadecimal_To_Binary = Hexadecimal_To_Binary & Mid(bStr, (i1 - 1) * 4 + 1, 4)

Next

Hexadecimal_To_Binary = Hexadecimal_To_Binary & Mid(strHex, 4, 2)

'十六进制转十进制

Hexadecimal_To_Binary = Hexadecimal_To_Binary & \"0\" & CStr(Val(\"&H\" & Right(strHex, 2)))

End Function

ThisWorkbook中代码如下：

Private Sub Workbook_Open() '工作簿一打开即刻初始化表单组合框数据并且在组合框中显示之前选择过的年份

Set shp_year_select = Sheets(1).Shapes(\"年份选择\")

shp_year_select.ControlFormat.RemoveAllItems

'万年历的年份范围初步设定为“1900～2100”

For i = 1900 To 2100

shp_year_select.ControlFormat.AddItem i

Next

'以下是重新还原表单组合框控件之前选定过的年份显示

yr = [a65535]

For i = 1 To shp_year_select.ControlFormat.ListCount

If yr = Val(shp_year_select.ControlFormat.List(i)) Then

n = i '遍历整个表单组合框所有元素，查找与yr是否相匹配的元素，若找到即刻记下该编号并存于n中

Exit For

End If

Next

shp_year_select.ControlFormat.ListIndex = n '让表单组合框显示找到的之前选择过的年份

End Sub

三、用方法一实现带农历万年历运行效果测试

(一)选择年份，呈待生成带农历万年历状态。如下图所示

图2 选择年份准备生成带农历万年历

(二)点击选择的年份，生成实实在在的带农历的万年历。如下图所示

图3 生成带农历万年历效果

(三)压下<清除日历数据>按钮，准备进行带农历的万年历数据清除。如下图所示

图4 准备清除带农历万年历数据

(四)压下状态下的<清除日历数据>按钮情况下点击该按钮，完成带农历万年历数据的清除，并将年份组合框内的显示提示年份置为最新当前时间的年份。如下图所示

图5 清除带农历万年历数据结果

四、技术亮点小结

(一)充分利用寻找农历闰月方法和压缩的农历字符还原方法完成公历转农历

(二)在定位Excel的万年历数据填充单元格时，用字符串处理函数处理农历生成的数据

(三)存储记忆上次打开万年历的数据

好了，本期我们就分享到这里吧，希望大家喜欢和收藏哦！

最后，还是感谢大家的持续关注(头条号：跟我学Office高级办公)、推广、点评哦！谢谢大家继续关注下期第二中方法实现带农历的万年历设计！