Excel/WPS如何计算农历生日日期?看起来简单,其实一点不简单!

[DBNum1][$-13000]"农历"m月d

=text(A2,[DBNum1][$-13000]"农历"m月d)

=SolarToLunar(日期单元格,日期显示格式)=SolarToLunar(A2,1)'显示六月廿九=SolarToLunar(A2,2)'显示“2025/6/29=SolarToLunar(A2,3)'乙巳年六月廿八

'====================================================================' 农历日期转换模块' 数据来源：紫金山天文台农历数据编码（1900-2100年）' 编码规则（每项4字节十六进制）：'   bit 0-3:  闰月月份（0=无闰月）'   bit 4-15: 12个月大小（bit4=正月,...,bit15=腊月），1=30天，0=29天'   bit 16-19: 闰月大小（1=30天，0=29天）'====================================================================Private Const LUNAR_DATA_STR As String = _    "0x04bd8,0x04ae0,0x0a570,0x054d5,0x0d260,0x0d950,0x16554,0x056a0,0x09ad0,0x055d5," & _    "0x04ae0,0x0a5b6,0x0a4d0,0x0d250,0x1d255,0x0b540,0x0d6a0,0x0ada2,0x095b0,0x14977," & _    "0x04970,0x0a4b0,0x0b4b5,0x06a50,0x06d40,0x1ab54,0x02b60,0x09570,0x052f2,0x04970," & _    "0x06566,0x0d4a0,0x0ea50,0x06e95,0x05ad0,0x02b60,0x186e3,0x092e0,0x1c8d7,0x0c950," & _    "0x0d4a0,0x1d8a6,0x0b550,0x056a0,0x1a5b4,0x025d0,0x092d0,0x0d2b2,0x0a950,0x0b557," & _    "0x06ca0,0x0b550,0x15355,0x04da0,0x0a5b0,0x14573,0x052b0,0x0a9a8,0x0e950,0x06aa0," & _    "0x0aea6,0x0ab50,0x04b60,0x0aae4,0x0a570,0x05260,0x0f263,0x0d950,0x05b57,0x056a0," & _    "0x096d0,0x04dd5,0x04ad0,0x0a4d0,0x0d4d4,0x0d250,0x0d558,0x0b540,0x0b6a0,0x195a6," & _    "0x095b0,0x049b0,0x0a974,0x0a4b0,0x0b27a,0x06a50,0x06d40,0x0af46,0x0ab60,0x09570," & _    "0x04af5,0x04970,0x064b0,0x074a3,0x0ea50,0x06b58,0x05ac0,0x0ab60,0x096d5,0x092e0," & _    "0x0c960,0x0d954,0x0d4a0,0x0da50,0x07552,0x056a0,0x0abb7,0x025d0,0x092d0,0x0cab5," & _    "0x0a950,0x0b4a0,0x0baa4,0x0ad50,0x055d9,0x04ba0,0x0a5b0,0x15176,0x052b0,0x0a930," & _    "0x07954,0x06aa0,0x0ad50,0x05b52,0x04b60,0x0a666,0x0a4e0,0x0d260,0x0ea65,0x0d530," & _    "0x05aa0,0x076a3,0x096d0,0x04afb,0x04ad0,0x0a4d0,0x1d0b6,0x0d250,0x0d520,0x0dd45," & _    "0x0b5a0,0x056d0,0x055b2,0x049b0,0x0a577,0x0a4b0,0x0aa50,0x1b255,0x06d20,0x0ada0," & _    "0x14b63,0x09370,0x049f8,0x04970,0x064b0,0x168a6,0x0ea50,0x06aa0,0x1a6c4,0x0aae0," & _    "0x092e0,0x0d2e3,0x0c960,0x0d557,0x0d4a0,0x0da50,0x05d55,0x056a0,0x0a6d0,0x055d4," & _    "0x052d0,0x0a9b8,0x0a950,0x0b4a0,0x0b6a6,0x0ad50,0x055a0,0x0aba4,0x0a5b0,0x052b0," & _    "0x0b273,0x06930,0x07337,0x06aa0,0x0ad50,0x14b55,0x04b60,0x0a570,0x054e4,0x0d160," & _    "0x0e968,0x0d520,0x0daa0,0x16aa6,0x056d0,0x04ae0,0x0a9d4,0x0a4d0,0x0d150,0x0f252," & _    "0x0d520"Private m_LunarData(1900 To 2100) As LongPrivate m_DataReady As BooleanPrivate Const TIAN_GAN As String = "甲乙丙丁戊己庚辛壬癸"Private Const DI_ZHI As String = "子丑寅卯辰巳午未申酉戌亥"Private Const MONTH_CN As String = "正二三四五六七八九十冬腊"' 初始化农历数据表（1900-2100年），将字符串常量解析为Long型数组，只执行一次Private Sub InitData()    If m_DataReady Then Exit Sub    Dim arr As Variant: arr = Split(LUNAR_DATA_STR, ",")    Dim i As Long    For i = 1900 To 2100        m_LunarData(i) = CLng("&H" & Mid(arr(i - 1900), 3))    Next i    m_DataReady = TrueEnd Sub' 根据农历年份数字返回干支纪年名称，如2025年返回"乙巳"Private Function GetYearName(ByVal y As Integer) As String    Dim n As Long: n = (y - 4) Mod 60    GetYearName = Mid(TIAN_GAN, (n Mod 10) + 1, 1) & Mid(DI_ZHI, (n Mod 12) + 1, 1)End Function' 返回农历月份的中文名称，isLeap=True时加"闰"前缀，如"六月"或"闰六月"Private Function GetMonthName(ByVal m As Integer, ByVal isLeap As Boolean) As String    Dim s As String    If m >= 1 And m <= 12 Then s = Mid(MONTH_CN, m, 1) & "月" Else s = m & "月"    If isLeap Then s = "闰" & s    GetMonthName = sEnd Function' 返回农历日期的中文名称，如"初一"、"廿三"等Private Function GetDayName(ByVal d As Integer) As String    If d < 1 Or d > 30 Then GetDayName = CStr(d): Exit Function    Select Case d        Case 1 To 10:   GetDayName = "初" & Mid("一二三四五六七八九十", d, 1)        Case 11 To 19:  GetDayName = "十" & Mid("一二三四五六七八九", d - 10, 1)        Case 20:        GetDayName = "二十"        Case 21 To 29:  GetDayName = "廿" & Mid("一二三四五六七八九", d - 20, 1)        Case 30:        GetDayName = "三十"    End SelectEnd Function' 返回指定农历年指定月份的天数（29或30天）Private Function MonthDays(ByVal y As Integer, ByVal m As Integer) As Integer    If (m_LunarData(y) And (2 ^ (m + 3))) <> 0 Then MonthDays = 30 Else MonthDays = 29End Function' 返回指定农历年的闰月月份（0=无闰月）Private Function LeapM(ByVal y As Integer) As Integer    LeapM = m_LunarData(y) And &HFEnd Function' 返回指定农历年闰月的天数（29或30天），无闰月时返回0Private Function LeapD(ByVal y As Integer) As Integer    If LeapM(y) > 0 Then        If (m_LunarData(y) And &H10000) <> 0 Then LeapD = 30 Else LeapD = 29    End IfEnd Function' 返回指定农历年的总天数（含闰月）Private Function YearDays(ByVal y As Integer) As Long    Dim t As Long, i As Integer    For i = 1 To 12: t = t + MonthDays(y, i): Next i    If LeapM(y) > 0 Then t = t + LeapD(y)    YearDays = tEnd Function' 核心转换：将公历日期转换为农历日期，通过引用参数返回农历年月日及闰月标志Private Sub ToLunar(ByVal dt As Date, ByRef ly As Integer, ByRef lm As Integer, ByRef ld As Integer, ByRef leap As Boolean)    InitData    Dim base As Date: base = DateSerial(1900, 1, 31)    If dt < base Then ly = 0: Exit Sub    Dim span As Long: span = CLng(dt - base)    Dim y As Integer: y = 1900    Do While y < 2100        Dim yd As Long: yd = YearDays(y)        If span < yd Then Exit Do        span = span - yd: y = y + 1    Loop    If y >= 2100 Then ly = 0: Exit Sub    ly = y    Dim lmT As Integer: lmT = LeapM(y)    Dim ldT As Integer: ldT = LeapD(y)    Dim fm As Boolean: fm = False    Dim m As Integer    For m = 1 To 12        Dim md As Integer: md = MonthDays(y, m)        If span < md Then            lm = m: leap = False: ld = span + 1: Exit Sub        End If        span = span - md        If lmT > 0 And m = lmT And Not fm Then            If span < ldT Then                lm = lmT: leap = True: ld = span + 1: Exit Sub            End If            span = span - ldT: fm = True        End If    Next m    ly = 0End Sub' ===== 公开接口 =====' SolarToLunar - 公历转农历' 参数：rng - 单元格引用（含公历日期）'       fmt - 1=中文月日（如"六月初一"），2=数字格式（如"2025/6/1"），3=中文全称（如"乙巳年六月初一"）' 公开接口：在Excel中作为自定义函数使用，根据fmt参数返回三种格式的农历日期字符串Public Function SolarToLunar(ByVal rng As Range, Optional ByVal fmt As Integer = 1) As String    On Error GoTo ErrH    If rng Is Nothing Then SolarToLunar = "#N/A": Exit Function    Dim dt As Date: dt = rng.Value    If Not IsDate(dt) Then SolarToLunar = "#VALUE!": Exit Function    If fmt < 1 Or fmt > 3 Then fmt = 1    Dim ly As Integer, lm As Integer, ld As Integer, lp As Boolean    ToLunar dt, ly, lm, ld, lp    If ly = 0 Then SolarToLunar = "#DATE!": Exit Function    If fmt = 2 Then        SolarToLunar = ly & "/" & lm & "/" & ld        Exit Function    End If    Dim mStr As String: mStr = GetMonthName(lm, lp)    Dim dStr As String: dStr = GetDayName(ld)    If fmt = 1 Then        SolarToLunar = mStr & dStr    Else        SolarToLunar = GetYearName(ly) & "年" & mStr & dStr    End If    Exit FunctionErrH: SolarToLunar = "#ERR!"End Function