本期，我们先来用第一种方法实现吧。
一、Excel前端带农历万年历界面设计
关于界面的设计，这里和上次那一期万年历的界面一样，这里不做过多描述，这里就只以截图直接呈现给各位吧。如下图所示
图1带农历的万年历界面
二、用方法一实现带农历万年历的功能代码
模块1中代码如下：
'强势自定义“公历”----“农历”互转函数
'---农历数据定义---
'先以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年即可）
PrivateConstylData="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"
'定义农历(阴历)每月的汉字大写日期“天”
PrivateConstylMd0="初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五"_
"十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十"
'定义农历(阴历)一年中的汉字大写日期“月”
PrivateConstylMn0="正二三四五六七八九十冬腊"
'定义农历(阴历)年中的“天干”(如：甲乙丙丁等)
PrivateConstylTianGan0="甲乙丙丁戊已庚辛壬癸"
'定义农历(阴历)年中的“地支”(如：子丑寅卯辰等)
PrivateConstylDiZhi0="子丑寅卯辰巳午未申酉戌亥"
'定义农历(阴历)年中的“属相”(如：鼠牛虎兔龙等)
PrivateConstylShu0="鼠牛虎兔龙蛇马羊猴鸡狗猪"
Publicshp_year_selectAsShape,y'定义公有全局变量年份选择组合框shp_year_select和用于存储选择的年份变量y，以便所有的过程都可以调用和回传数据
SubRun_Fill_Caler()'运行填充日历
[b4].Select
n=shp_year_
y=shp_year_(n)
[O1]=y"年历""["Mid(GetYLDate(y"-6-1"),4,6)"]"
Fill_Caler_Datas'调用“填充日历数据”过程
[a65535]=y'将选择过的年份存储在单元格"A65535"中
Sub
SubFill_Caler_Datas()'填充日历数据
Dimrg(1To12)AsRange'定义12个元素的的范围区域对象数组
'为区域对象数组的每个区域对象元素对象指派这12个区域对象具体的实体
Setrg(1)=[b5:h10]:Setrg(2)=[j5:p10]:Setrg(3)=[r5:x10]:Setrg(4)=[z5:af10]
Setrg(5)=[b15:h20]:Setrg(6)=[j15:p20]:Setrg(7)=[r15:x20]:Setrg(8)=[z15:af20]
Setrg(9)=[b25:h30]:Setrg(10)=[j25:p30]:Setrg(11)=[r25:x30]:Setrg(12)=[z25:af30]
Fori=1To12
SelectCasei
Case1,3,5,7,8,10,12:days_31y,i,rg(i)
Case4,6,9,11:days_30y,i,rg(i)
Case2:days_29_Or_28y,i,rg(i)
Select
Next
Sub
SubErse_Caler_Datas()'清空日历数据
DimrgAsRange
Setrg=[5:10,15:20,25:30]
[b4].Select
[O1]="----年历[-----年]"
yr=Year(Date)
'以下是定位当今日期的年份在表单组合框中显示
Fori=1Toshp_year_
Ifyr=Val(shp_year_(i))Then
n=i
ExitFor
If
Next
shp_year_=n
Sub
Subdays_31(y,m,rAsRange)'月大--31天
DimdaAsDate,d
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号在日历星期区域的定位位置
Ford=1To31
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)'拆解阴历月日中的日子
Ifyl_d="初一"Thenyl_d=yl_m'若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子
r(p)=dChr(10)yl_d'将公历日期和对应的农历日期合在一起填入到p处正确位置
Ifda=DateThenr(p).Select'若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态
Next
Sub
Subdays_30(y,m,rAsRange)'月小--30天
DimdaAsDate,d
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号在日历星期区域的定位位置
Ford=1To30
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)'拆解阴历月日中的日子
Ifyl_d="初一"Thenyl_d=yl_m'若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子
r(p)=dChr(10)yl_d'将公历日期和对应的农历日期合在一起填入到p处正确位置
Ifda=DateThenr(p).Select'若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态
Next
Sub
Subdays_29_Or_28(y,m,rAsRange)'闰年2月份29天，平年2月份28天(例如2020年就是闰年)
DimdaAsDate,d
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号在日历星期区域的定位位置
IfIs_LeepYear(y)Then'闰年2月份天数
Ford=1To29
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)'拆解阴历月日中的日子
Ifyl_d="初一"Thenyl_d=yl_m'若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子
r(p)=dChr(10)yl_d'将公历日期和对应的农历日期合在一起填入到p处正确位置
Ifda=DateThenr(p).Select'若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态
Next
Else'平年2月份天数
Ford=1To28
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)'拆解阴历月日中的日子
Ifyl_d="初一"Thenyl_d=yl_m'若拆解的日子是“初一”，则即刻用该月的月份替代该阴历月份的首个日子
r(p)=dChr(10)yl_d'将公历日期和对应的农历日期合在一起填入到p处正确位置
Ifda=DateThenr(p).Select'若选择年份后不断瞬时生成的日期da和现在的日期匹配，则将当前填充的日期单元格选择成活动状态
Next
If
Sub
FunctionIs_LeepYear(y)AsBoolean'给定的年份是否为闰年LeepYear的判断
If(yMod400=0)Or(yMod1000AndyMod4=0)Then
Is_LeepYear=True
Else
Is_LeepYear=False
If
Function
'自定义“公历转农历”日期函数
FunctionGetYLDate(ByValstrDateAsString)AsString
OnErrorGoToExitFunction_Label
IfNotIsDate(strDate)ThenExitFunction'如果参数strDate非日期的无效字符串，则退出本函数工作
'定义setDate--设置的未来日期，tYear--未来日期的本年份，tMonth--本月份，tDay--本日子
DimsetDateAsDate,tYearAsInteger,tMonthAsInteger,tDayAsInteger
setDate=CDate(strDate)'为该GetYLDate()函数参数的字符串转换后的日期赋予设定的日期
tYear=Year(setDate):tMonth=Month(setDate):tDay=Day(setDate)'年、月、日分别取值
'如果不是有效有日期，退出
IftYear2100OrtYear1900ThenExitFunction
'定义daList()--是元素为18位日期二进制字符串数组，conDate--农历新年日期，thisMonths--本年的二进制_
月份信息(可能包含闰月)
DimdaList()AsString*18,conDateAsDate,thisMonthsAsString
'定义AddYear--是相对1900年递增的年，AddMonth--月份增量，AddDay--天数增量，getDay--农历新年和设_
之日期相差天数
DimAddYearAsInteger,AddMonthAsInteger,AddDayAsInteger,getDayAsInteger
'定义YLyear--农历(阴历)年的字符串，YLShuXing--农历(阴历)年的属相
DimYLyearAsString,YLShuXingAsString
'定义dd0--农历(阴历)年的阴历日子，mm0--农历(阴历)年的阴历月，ganzhi()--每个元素为2个字符的天干地_
支数组
Dimdd0AsString,mm0AsString,ganzhi(0To59)AsString*2
'定义RunYue--农历(阴历)年是否闰月的布尔型标志，RunYue1--农历(阴历)年闰月月份
DimRunYueAsBoolean,RunYue1AsInteger,mDaysAsInteger,iAsInteger
'加载2年内的农历数据
ReDimdaList(tYear-1TotYear)
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'相差天数
IfgetDay1ThenAddYear=AddYear-1:GoToinitYL
thisMonths=Left(daList(AddYear),14)'前14位为本年的二进制月份信息(可能有闰月)存于thisMonths中
RunYue1=Val("H"Right(thisMonths,1))'闰月月份
IfRunYue10Then'如果有闰月，则立即修正本年的二进制月份信息thisMonths，形成真正有效的二进制序_
列信息
thisMonths=Left(thisMonths,RunYue1)Mid(thisMonths,13,1)Mid(thisMonths,RunYue1+1)
If
thisMonths=Left(thisMonths,13)'最后一次修正本年的二进制月份信息thisMonths，直接取13个月的情况
Fori=1To13'遍历1～13个月，找到并计算含闰月的有效天数，同时退出循环
mDays=29+CInt(Mid(thisMonths,i,1))
IfgetDaymDaysThen
getDay=getDay-mDays
Else
IfRunYue10Then'如果有闰月，则进一步根据i的值情况做如下处理
Ifi=RunYue1+1ThenRunYue=True'若i确系为闰月，则将闰月标志置为真
IfiRunYue1Theni=i-1'若i大于闰月月份，则将将i回退修正
If
AddMonth=i'最终记录下i作为真正的增量月份存入AddMonth
AddDay=getDay'同时，将得到的天数差作为增量天数
ExitFor
If
Next
dd0=Mid(ylMd0,(AddDay-1)*2+1,2)'用查找表的形式定位当前日期对应的农历(阴历)日子
mm0=Mid(ylMn0,AddMonth,1)+"月"'用查找表的形式定位当前日期对应的农历(阴历)月份
Fori=0To59'0～59表示60年一个甲子，表示以60年一个轮回的形式，通过查找表精准定位每年的天干地支
ganzhi(i)=Mid(ylTianGan0,(iMod10)+1,1)+Mid(ylDiZhi0,(iMod12)+1,1)
Next
YLyear=ganzhi((AddYear-4)Mod60)'通过查找表形式得出阴历年的天干地支表示形式
YLShuXing=Mid(ylShu0,((AddYear-4)Mod12)+1,1)'通过查找表形式得出阴历年的属相表示形式
IfRunYueThenmm0="闰"mm0'如果某阴历月份有闰月，特别加上“闰X月”的形式
GetYLDate="农历："YLyear"("YLShuXing")年"mm0dd0'拼接当前日期的完整农历信息
ExitFunction_Label:
Function
'将压缩的阴历字符还原
PrivateFunctionHexadecimal_To_Binary(ByValstrHexAsString)AsString'十六进制转二进制
DimiAsInteger,i1AsInteger,tmpVAsString
ConsthStr="0123456789ABCDEF"
ConstbStr="0000000100100011010001010110011110001001101010111100110111101111"
tmpV=UCase(Left(strHex,3))
'以下是十六进制转二进制的具体操作
Fori=1ToLen(tmpV)
i1=InStr(hStr,Mid(tmpV,i,1))
Hexadecimal_To_Binary=Hexadecimal_To_BinaryMid(bStr,(i1-1)*4+1,4)
Next
Hexadecimal_To_Binary=Hexadecimal_To_BinaryMid(strHex,4,2)
'十六进制转十进制
Hexadecimal_To_Binary=Hexadecimal_To_Binary"0"CStr(Val("H"Right(strHex,2)))
Function
ThisWorkbook中代码如下：
PrivateSubWorkbook_Open()'工作簿一打开即刻初始化表单组合框数据并且在组合框中显示之前选择过的年份
Setshp_year_select=Sheets(1).Shapes("年份选择")
shp_year_
'万年历的年份范围初步设定为“1900～2100”
Fori=1900To2100
shp_year_
Next
'以下是重新还原表单组合框控件之前选定过的年份显示
yr=[a65535]
Fori=1Toshp_year_
Ifyr=Val(shp_year_(i))Then
n=i'遍历整个表单组合框所有元素，查找与yr是否相匹配的元素，若找到即刻记下该编号并存于n中
ExitFor
If
Next
shp_year_=n'让表单组合框显示找到的之前选择过的年份
Sub
三、用方法一实现带农历万年历运行效果测试
(一)选择年份，呈待生成带农历万年历状态。如下图所示
图2选择年份准备生成带农历万年历
图3生成带农历万年历效果
(三)压下清除日历数据按钮，准备进行带农历的万年历数据清除。如下图所示
图4准备清除带农历万年历数据
图5清除带农历万年历数据结果
四、技术亮点小结
(一)充分利用寻找农历闰月方法和压缩的农历字符还原方法完成公历转农历
(二)在定位Excel的万年历数据填充单元格时，用字符串处理函数处理农历生成的数据
(三)存储记忆上次打开万年历的数据
好了，本期我们就分享到这里吧，希望大家喜欢和收藏哦！
