ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1086|回复: 2

求农历转公历代码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-10-23 12:12 | 显示全部楼层 |阅读模式
想把出生日期转为公历时间,哪位大神有代码吗

TA的精华主题

TA的得分主题

发表于 2019-10-23 12:29 | 显示全部楼层
搜索一下,论坛好几个

TA的精华主题

TA的得分主题

发表于 2019-11-5 01:39 | 显示全部楼层
论坛中有很多,给你搬来一个

'阴阳历转换 和 阴阳历生日
'Version: 1.1 2005-9-1
'Author: James Zhuang
'Lunar(SolarDate[, Part = 0 | 1 | 2 | 3])   阳历转换成阴历
'                         Part = 0, all; Part = 1, lunar year; Part = 2, lunar month; Part = 3, lunar day
'Solar(LunarDate[, LunarMonth = 0 | 1])     阴历转换成阳历
Type ConvDataA
    leapmonth As Integer
    month(1 To 13) As Integer
    sp_month As Integer 'Solar month of Spring Festival
    sp_day As Integer   'Solar day   of Spring Festival
End Type
Private Function LunarData(q_year) As ConvDataA
    Dim D As Long
    Dim month(1 To 13) As Integer
'1900-2200
LunarCal = Array(&H84B6BF, &H4AE53, &HA5748, &H5526BD, &HD2650, &HD9544, &H46AAB9, &H56A4D, &H9AD42, &H24AEB6, &H4AE4A, _
&H6A4DBE, &HA4D52, &HD2546, &H5D52BA, &HB544E, &HD6A43, &H296D37, &H95B4B, &H749BC1, &H49754, &HA4B48, &H5B25BC, &H6A550, &H6D445, &H4ADAB8, &H2B64D, &H95742, &H2497B7, &H4974A, &H664B3E, _
&HD4A51, &HEA546, &H56D4BA, &H5AD4E, &H2B644, &H393738, &H92E4B, &H7C96BF, &HC9553, &HD4A48, &H6DA53B, &HB554F, &H56A45, &H4AADB9, &H25D4D, &H92D42, &H2C95B6, &HA954A, &H7B4ABD, &H6CA51, _
&HB5546, &H555ABB, &H4DA4E, &HA5B43, &H352BB8, &H52B4C, &H8A953F, &HE9552, &H6AA48, &H7AD53C, &HAB54F, &H4B645, &H4A5739, &HA574D, &H52642, &H3E9335, &HD9549, &H75AABE, &H56A51, &H96D46, _
&H54AEBB, &H4AD4F, &HA4D43, &H4D26B7, &HD254B, &H8D52BF, &HB5452, &HB6A47, &H696D3C, &H95B50, &H49B45, &H4A4BB9, &HA4B4D, &HAB25C2, &H6A554, &H6D449, &H6ADA3D, &HAB651, &H95746, &H5497BB, _
&H4974F, &H64B44, &H36A537, &HEA54A, &H86B2BF, &H5AC53, &HAB647, &H5936BC, &H92E50, &HC9645, &H4D4AB8, &HD4A4C, &HDA541, &H25AAB6, &H56A49, &H7AADBD, &H25D52, &H92D47, &H5C95BA, &HA954E, _
&HB4A43, &H4B5537, &HAD54A, &H955ABF, &H4BA53, &HA5B48, &H652BBC, &H52B50, &HA9345, &H474AB9, &H6AA4C, &HAD541, &H24DAB6, &H4B64A, &H6A57BD, &HA4E51, &HD2646, &H5E933A, &HD534D, &H5AA43, _
&H36B537, &H96D4B, &HB4AEBF, &H4AD53, &HA4D48, &H6D25BC, &HD254F, &HD5244, &H5DAA38, &HB5A4C, &H56D41, &H24ADB6, &H49B4A, &H7A4BBE, &HA4B51, &HAA546, &H5B52BA, &H6D24E, &HADA42, &H355B37, _
&H9374B, &H8497C1, &H49753, &H64B48, &H66A53C, &HEA54F, &H6ABC4, &H4AB638, &HAAE4C, &H92E42, &H3C9735, &HC9649, &H7D4ABD, &HD4A51, &HDA545, &H55AABA, &H56A4E, &HA6D43, &H452EB7, &H52D4B, _
&H8A95BF, &HA9553, &HB4A47, &H6B553B, &HAD54F, &H55A45, &H4A5D38, &HA5B4C, &H52B42, &H3A93B6, &H69349, &H7729BD, &H6AA51, &HAD546, &H54DABA, &H4B64E, &HA5743, &H452738, &HD16CA, &H8E933E, _
&HD5252, &HDAA47, &H66B53B, &H56D4F, &H4AE45, &H4A4EB9, &HA2DCC, &HD1541, &H2D92B5, &HD5349, &H7DA9BD, &HB5AD1, &H55D47, &H54ADBC, &H49B4F, &HA4B44, &H4D25B8, &HAA5CC, &H9B52BF, &H6D3D3, _
&HAD6C8, &H655BBD, &H93750, &H49746, &H464BBA, &H54B4E, &H6A5C2, &H36D2B6, &H6AACA, &H7AB5BE, &HAAD51, &H52EC7, &H5C97BB, &HA96CF, &HD4AC3, &H4EA5B7, &HD954B, &HB5AAC1, &H56AD3, &HA6D48, _
&H652EBD, &H52D51, &HA8D45, &H5D4AB9, &HB2ACD, &HB5542, &H256AB6, &H55ACA, &H7A5DBE, &HA5B52, &H52B47, &H5A8BBB, &H68B4F, &H72944, &H4B55B7, &H6B54B, &HB2DAC1, &H4B6D4, &HA5748, &H6517BD, _
&HD16D0, &HE8B45, &H56A9B9, &HDA9CC, &H5B5C2, &H32B6B7, &H2AECA, &H7A2EBE, &HA2D52, &HD1547, &H6D4ABA, &HB52CE, &HD6943, &H45ADB8, &H55B4B, &HA2ADC1, &H45B54, &HA2B49, &H6A95BC, &HA9550, _
&HB4AC5, &H5B55B9, &HAD54C, &H55BC2, &H325BB7, &H457CB, &H762BBE, &H52B52, &H69547, &H66CABB, &H5AA4E, &HAB543, &H4536B8, &H4AF4C, &HA573F, &H272BB5, &HD2B48, &H6E95BC, &HD55CF, &H5ABC5, _
&H5AB5B9, &HA6DCD, &H4AEC2, &H3A55B6, &HA4D4A, &H7D25BE, &HB2951, &HB5546, &H656ABB, &H2DB4F, &H95D44, &H44ADB9)

startyear = 1900
ng = LunarCal(q_year - startyear)
    D = &H100000
    LunarData.leapmonth = Int(ng / D)
    ng = ng Mod D
   
    D = &H80
    mdata = Int(ng / D)
    ng = ng Mod D
   
    D = &H20
    LunarData.sp_month = Int(ng / D)
    LunarData.sp_day = ng Mod D
   
    D = &H1000
    i = 1
    Do
        LunarData.month(i) = 29 + Int(mdata / D)
        mdata = mdata Mod D
        If D = 1 Then Exit Do
        D = D / 2
        i = i + 1
    Loop
    If LunarData.leapmonth = 0 Then
       LunarData.month(13) = 0
    Else
       b = LunarData.month(LunarData.leapmonth + 1)
       For i = LunarData.leapmonth + 1 To 12
           LunarData.month(i) = LunarData.month(i + 1)
       Next i
       LunarData.month(13) = b
    End If
End Function

Function lunar(Solar_date, Optional Part As Integer = 0) As String
'Part = 0, all; Part = 1, lunar year; Part = 2, lunar month; Part = 3, lunar day
    Dim a As ConvDataA
    nlrmc = "初一初二初三初四初五初六初七初八初九初十十一十二十三十四十五十六十七十八十九二十廿一廿二廿三廿四廿五廿六廿七廿八廿九三十"
    nlymc = "正二三四五六七八九十冬腊"
    l_year = Year(Solar_date)
    a = LunarData(l_year)
    sp_date = DateSerial(l_year, a.sp_month, a.sp_day)
    If sp_date > Solar_date Then
        l_year = l_year - 1
        a = LunarData(l_year)
        sp_date = DateSerial(l_year, a.sp_month, a.sp_day)
    End If
    l_day = Solar_date - sp_date
    l_month = 1
    IS_lunar_leapmonth = False
   
    y = a.month(l_month)
    Do While l_day >= y
        l_day = l_day - y
        If l_month = a.leapmonth Then IS_lunar_leapmonth = (Not IS_lunar_leapmonth)
        If IS_lunar_leapmonth Then
            y = a.month(13)  '???
        Else
            l_month = l_month + 1
            y = a.month(l_month)
        End If
    Loop
    l_day = l_day ' + 1
    l_day1 = Int(l_day + 1)
    l_time = Solar_date - Int(Solar_date): l_time = Format(l_time, "hh:mm:ss")
   
    If IS_lunar_leapmonth Then r_month = "闰"
   
    lunar = l_year & "-" & r_month & l_month & "-" & l_day1
        
    nlnm = sizhu(Solar_date, 1) & sizhu(Solar_date, 5) & "年"
    nlym = r_month & Mid(nlymc, l_month, 1) & "月"
    nlrm = Mid(nlrmc, l_day1 * 2 - 1, 2)
    nlnyr = nlnm & nlym & nlrm
    lunar = Choose(Part + 1, lunar, l_year, r_month & l_month, l_day1, l_time, nlrm, nlnyr)
End Function

Function solar(Lunar_date, Optional IS_lunar_leapmonth As Integer = 0) As String
    'IS_lunar_leapmonth = 0, No leap month; IS_lunar_leapmonth = 1, is leap month
    Dim a As ConvDataA
    Lunar_date = Split(Lunar_date, "-")
    s_year = Lunar_date(0)
    If InStr(Lunar_date(1), "闰") > 0 Then IS_lunar_leapmonth = 1
    Lunar_date(1) = Val(Replace(Lunar_date(1), "闰", ""))
    a = LunarData(s_year)
    sp_date = DateSerial(s_year, a.sp_month, a.sp_day)
    If Lunar_date(1) <> a.leapmonth Then IS_lunar_leapmonth = 0
    x = Lunar_date(2)
    tm = Lunar_date(1) + IS_lunar_leapmonth - 1
    For i = 1 To tm
        x = x + a.month(i)
        If i = a.leapmonth And IS_lunar_leapmonth = 0 Then
            x = x + a.month(13)
        End If
    Next
   
    s_date = sp_date + x - 1
    If s_date < 61 Then s_date = s_date + 1
    solar = s_date
End Function

Function lunarbirth(Solar_birthday As Date, Optional Inquire_year As Integer) As String
'公历生日转农历转当年公历生日
    ssh = Right(lunar(Solar_birthday), 2)
    If Inquire_year = 0 Then                                 '已经解决农历三十的问题-转29
        Inquire_year = Left(lunar(Now), 4)
        lunarbirth = solar(Inquire_year & Replace(Mid(lunar(Solar_birthday), 5), "闰", ""))
        If CDate(lunarbirth) < Now - 1 Then Inquire_year = Inquire_year + 1
    End If
    birth = solar(Inquire_year & Replace(Mid(lunar(Solar_birthday), 5), "闰", ""))
    sshh = Right(lunar(CDate(birth)), 2)
'    Debug.Print ssh, sshh
    lunarbirth = birth
    If ssh <> sshh Then lunarbirth = CDate(birth) - 1
End Function
Function solarbirth(Solar_birthday As Date, Optional Inquire_year As Integer) As String
    If Inquire_year = 0 Then
        Inquire_year = Year(Now)
        solarbirth = DateSerial(Inquire_year, month(Solar_birthday), Day(Solar_birthday))
        If CDate(solarbirth) < Now - 1 Then Inquire_year = Inquire_year + 1
    End If
    solarbirth = DateSerial(Inquire_year, month(Solar_birthday), Day(Solar_birthday))
End Function
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 17:20 , Processed in 0.039254 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表