2008年日历带农历_头条文章--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
2008年日历带农历_头条文章--Excel中带农历的万年历设计方法一相关推荐
- 在excel日期比对大小_如何在Excel中防止分组日期
在excel日期比对大小 As a teenager, group dates can be fun. If you have strict parents, that might be the on ...
- python命名规则数字开头的成语_浅谈Python中带_的变量或函数命名
搜索热词 Python 的代码风格由 PEP 8 描述.这个文档描述了 Python 编程风格的方方面面.在遵守这个文档的条件下,不同程序员编写的 Python 代码可以保持最大程度的相似风格.这样就 ...
- excel切片器_不喜欢Excel自带的切片器样式,我一秒设置个性化切片器
一般在excel中插入的切片器都是默认样式的,即使根据自带模板修改之后也不是很满意的话,小编来教大家设置自己的切片器吧! 库存切片器 第一步:插入切片器 第二步:选择产品名称确定,更改产品名称后实时显 ...
- excel 重复方差分析_如何在Excel中运行方差方差分析的两种方法
excel 重复方差分析 Recently, we looked at how to Perform a One-Way Analysis of Variance in Excel. In today ...
- excel日期相减去除周末_仅在Excel中允许周末日期
excel日期相减去除周末 With Excel Data Validation, you can add rules to a data entry sheet, and control what ...
- 合并的表格怎么加横线_如何在excel中文字后面加横线
如何在excel中文字后面加横线以下文字资料是由(历史新知网www.lishixinzhi.com)小编为大家搜集整理后发布的内容,让我们赶快一起来看一下吧! 如何在excel中文字后面加横线 好办啊 ...
- excel表格怎么调整行高和列宽_如何在Excel中竖向批量插入图片,这个简单方法你知道吗...
酌酒与君君自宽,人情翻覆似波澜.白首相知犹按剑,朱门先达笑弹冠.草色全经细雨湿,花枝欲动春风寒.世事浮云何足问,不如高卧且加餐. --[唐]王维<酌酒与裴迪> 不知道大家有没有遇到过这种情 ...
- 符号在excel中的引用_如何在Excel中添加项目符号
&符号在excel中的引用 There's no built-in feature for bullets in Excel, like there is in a Word document ...
- excel中去重计数_如何在Excel中计数
excel中去重计数 There are lots of different ways to count things in Excel – maybe you need to count the n ...
- excel日历弄到html,怎么在excel中插入日历
怎么在excel中插入日历 导语:接下来,让小编告诉你怎么在excel中插入日历吧.一起来看看吧! 怎么在excel中插入日历 输入日期时避免顿号的使用. 为什么这么说了,请看下面的对比图.我们能很明 ...
最新文章
- R语言dataframe计算满足筛选条件的行的个数(筛选满足条件的数据行并计数):类似于excel的countif函数
- 陈松松:视频营销成交率低,这三个因素没到位
- bupt summer training for 16 #2 ——计算几何
- 随机森林算法4种实现方法对比测试:DolphinDB速度最快,XGBoost表现最差
- 文计笔记1: 计算机基本原理
- 计算机主机安装系统安装系统,系统重装
- 前端框架:执行流程分析之路由与菜单
- WebBenchmark动态测试Webapi
- java emoji编码转换_java转换emoji表情
- 组织机构代码输入测试用例_测试代码以用于过大的输入
- 常问 3: 谈谈MySQL共享锁与排他锁
- js中html标签变文字颜色,javascript – 更改contenteditable div中文本的颜色
- java利用循环打印AVA,JAVA语言-AVA文件流
- 计算机二级C操作题题型
- Log4j2 Zero Day 漏洞 Apache Flink 应对指南
- GD32f103介绍第一章
- Flutter sksl 着色器预热
- cubietruck下配置aria2+yaaw
- golang 格式化时间总结
- leetcode13——罗马数字转整数(简单,0)