请高手分享一段VBA阳历转农历的自定义函数代码！

大难不死

有所不知，湖北一研究农历的卦象的专家是中了一等奖的高人！

大难不死

农历研究的人价值是现代人无法理解的！所以我也要研究农历及转换函数或VBA！忘记了我也是上世纪70年代的老农民一个！

大难不死

分析得这么透彻几乎专家呼！可你有没有转换为农历或农历节气的VBA代码或宏模块？我傻等！

lichaobin

我也是从阴历及阳历转换走出来的人，我想说的是，农历不是过时，确实真的在给我们的生活中起到了重要的指导作用。
其实本来就是应该根据天文台确认的阴历修正结果及阴历通用规则来做阴阳历的转换。
在这里，大家对此不了解，所以没有通行的转换代码，嘴皮子可以争，也反映出我们对历法的常识没了解透，以致于没法编好我们预知的阳阴历转换代码。
弱弱的说一句，2楼的转换代码虽然不错，但是，尽可能显示出通行的公历日期来反映就好了，比如格式为：
YYYY-MM-DD 星期
因为这个在我们春节、中秋等传统节假日期的阴历同比报表，数据用的是非常多的。

lichaobin

我多加了注释，提供给改代码之用。

'历转农历模块（vba）摘录

'公历转农历模块
'原创：互联网
'修正：阿勇 2005/1/12

'// 农历数据定义 //
'先以 H2B 函数还原成长度为 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年）
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 = "鼠牛虎兔龙蛇马羊猴鸡狗猪"

'公历日期转农历
Function GetYLDate(ByVal strDate As String) As String  '获取GET阴历日期YLDate函数(阳历日期字符串) 函数返回也是字符串

On Error GoTo aErr     '在出现错误时跳至aErr行

    If Not IsDate(strDate) Then Exit Function   '如果阳历日期字符串属日期格式，则运行函数，否则退出

    '定义变量:setDate变量为将要转换的阳历日期,tYear,tMonth,tDay变量为此阳历的年,月,日
    Dim setDate As Date, tYear As Integer, tMonth As Integer, tDay As Integer
    setDate = CDate(strDate)  '取阳历日期字符串并转换成日期，再将年月日值赋于变量
    tYear = Year(setDate): tMonth = month(setDate): tDay = Day(setDate)
阴历和阳历转换函数超强大-斌核过.zip (33.93 KB, 下载次数: 397)

2013-2-2 01:45 上传

点击文件名下载附件
阴阳历转换函数

    '如果不是有效有日期，退出
    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 为增加年数,AddMonth 为增加月份数,AddDay 为增加天数,getdaY 为取天数变量
    Dim AddYear As Integer, AddMonth As Integer, AddDay As Integer, getDay As Integer
    '定义阴历年份及属相
    Dim YLyear As String, YLShuXing As String
    '定义dd0,mm0为阴历天数，月份，以及阴历干支变量
    Dim dd0 As String, mm0 As String, ganzhi(0 To 59) As String * 2
    '定议RunYue变量是否为闰月,Runyeu1为闰月值,mDays为闰月天数
    Dim RunYue As Boolean, RunYue1 As Integer, mDays As Integer, i As Integer

    '加载2年内的农历数据
    ReDim daList(tYear - 1 To tYear)  '以阳历的前一年到阳历今年这两年
    '以H2B函数在202年阴历常量（16位进制表示）中还原头一年的阴历代码（18位字符串）,即
    '先以 H2B 函数还原成长度为 18 的字符串，其定义如下：
    '前12个字节代表1-12月：1为大月，0为小月；压缩成十六进制(1-3位)
    '第13位为闰月的情况，1为大月30天，0为小月29天；(4位)
    '第14位为闰月的月份，如果不是闰月为0，否则给出月份(5位)
    '最后4位为当年农历新年的公历日期，如0131代表1月31日；当作数值转十六进制(6-7位)

    '第一年
    daList(tYear - 1) = H2B(Mid(ylData, (tYear - 1900) * 8 + 1, 7))
    '第二年
    daList(tYear) = H2B(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))
    '按照转换的年月日，得到阳历表示的农历新年日期  正月初一前一晚（除夕日）,以阳历YYYYMMDD格式表示
    conDate = DateSerial(AddYear, AddMonth, AddDay)     '农历新年日期

    '按阳历的规则进行天数差异比较，如果判断将要转换的阳历日期在除夕日之前，则减1
    getDay = DateDiff("d", conDate, setDate) + 1        '相差天数
    If getDay < 1 Then AddYear = AddYear - 1: GoTo initYL

    '取闰月月份,如果不是闰月为0，否则给出月份(5位)
    thisMonths = Left(daList(AddYear), 14)
    '初涉取润月的月份值
    RunYue1 = Val("&H" & Right(thisMonths, 1))           '闰月月份
    If RunYue1 > 0 Then                                  '有闰月
        '取润月时的月份
        thisMonths = Left(thisMonths, RunYue1) & Mid(thisMonths, 13, 1) & Mid(thisMonths, RunYue1 + 1)
    End If
    '最终润月值
    thisMonths = Left(thisMonths, 13)

    For i = 1 To 13                                      '计算天数
        mDays = 29 + CInt(Mid(thisMonths, i, 1))
        If getDay > mDays Then
            getDay = getDay - mDays
        Else
            If RunYue1 > 0 Then
                If i = RunYue1 + 1 Then RunYue = True
                If i > RunYue1 Then i = i - 1
            End If

            AddMonth = i
            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
        ganzhi(i) = Mid(ylTianGan0, (i Mod 10) + 1, 1) + Mid(ylDiZhi0, (i Mod 12) + 1, 1)
    Next i

    YLyear = ganzhi((AddYear - 4) Mod 60)       '阴历干支年份表示
    YLShuXing = Mid(ylShu0, ((AddYear - 4) Mod 12) + 1, 1)  '年份属相表示
    If RunYue Then mm0 = "闰" & mm0
    '最终输出阴历日期，格式是农历干支（属相）年农历月农历日
    'mm0为"正二三四五六七八九十冬腊",润年最多加个润字
    'dd0为初一至初十，十一至廿十，廿一至三十
    GetYLDate = "农历" & YLyear & "(" & YLShuXing & ")年" & mm0 & dd0   '

aErr:

End Function

lzqmsy

留个记号,学习一下,谢谢楼主

lbay

下载收藏了！

高度保密

既然能用代码转换出来，就说明存在规律，存在规律就值得研究，希望能有人总结出个新的历法，既简单又实用就好了。
另外，我的切身体会，春节回到老家就只记得农历了，完了又基本只记得公历了，所以经常连家人的生日都忘了

xsy我可以很好

八字推排.rar (359.96 KB, 下载次数: 318)

2013-11-29 07:00 上传

点击文件名下载附件

bobgu

不错，农历不能丢吧。挺下。收藏了{:soso_e142:}