Cách chuyển ngày âm sang ngày dương và ngược lại với VBA

Bạn đã bao giờ gặp khó khăn với các dữ liệu ngày tháng năm hay không biết rõ ngày âm lịch, dương lịch của ngày mình cần tìm là gì. Hôm nay, Gitiho.com sẽ cùng bạn khám phá cách chuyển ngày từ âm lịch sang dương lịch và ngược lại nhé!

Tuyệt đỉnh VBA - Viết code trong tầm tay

Cách chuyển ngày dương sang ngày âm

Để chuyển ngày dương lịch sang ngày âm lịch chúng ta sẽ sử dụng công thức hàm Solar2Lunar theo ảnh sau:

Cách chuyển âm lịch sang dương lịch

Dựa vào hàm Solar2Lunar, chúng ta có thể dễ dàng chuyển ngày âm lịch sang dương lịch bằng cách đảo ngược công thức hàm lại Lunar2Solar

Để làm cho việc sử dụng hàm đơn giản hơn, ta viết thêm 1 hàm bao ngoài như sau:

• Function AmLich(d as Date)
• AmLich = Solar2Lunar(day(d),month(d),year(d))
• end Function

Xem thêm: Hàm tính ra năm âm lịch bằng VBA

Code chuyển ngày âm lịch sang ngày dương lịch với VBA

Dưới đây, Gitiho hướng dẫn bạn cách viết code trong VBA để chuyển đổi âm lịch sang dương lịch

[edit-table0]Option ExplicitConst PI As Double = 3.14159265358979 ' Atn(1) * 4
Nguồn: https://www.informatik.uni-leipzig.de/~duc/amlich/LunarSolar.bas
' Compute the (integral) Julian day number of day dd/mm/yyyy, i.e., the number' of days between 1/1/4713 BC (Julian calendar) and dd/mm/yyyy.' Formula from http://www.tondering.dk/claus/calendar.htmlFunction jdFromDate(ByVal dd As Long, ByVal mm As Long, ByVal yy As Long) As Long    Dim a As Double, y As Long, m As Long, jd As Long    a = Fix((14 - mm) / 12)    y = yy + 4800 - a    m = mm + 12 * a - 3    jd = dd + Fix((153 * m + 2) / 5) + 365 * y _        + Fix(y / 4) - Fix(y / 100) + Fix(y / 400) - 32045    If jd < 2299161 Then        jd = dd + Fix((153 * m + 2) / 5) + 365 * y + Fix(y / 4) - 32083    End If    jdFromDate = jdEnd Function
' Convert a Julian day number to day/month/year. Parameter jd is an integerFunction jdToDate(ByVal jd As Long)    Dim a As Long, b As Long, c As Long, d As Long, e As Long, m As Long    Dim Day As Long, Month As Long, Year As Long    If (jd > 2299160) Then ' After 5/10/1582, Gregorian calendar        a = jd + 32044        b = Fix((4 * a + 3) / 146097)        c = a - Fix((b * 146097) / 4)    Else        b = 0        c = jd + 32082    End If    d = Fix((4 * c + 3) / 1461)    e = c - Fix((1461 * d) / 4)    m = Fix((5 * e + 2) / 153)    Day = e - Fix((153 * m + 2) / 5) + 1    Month = m + 3 - 12 * Fix(m / 10)    Year = b * 100 + d - 4800 + Fix(m / 10)    jdToDate = Array(Day, Month, Year)End Function
' Compute the time of the k-th new moon after the new moon of 1/1/1900 13:52 UCT' (measured as the number of days since 1/1/4713 BC noon UCT,' e.g., 2451545.125 is 1/1/2000 15:00 UTC).' Returns a floating number, e.g.,' 2415079.9758617813 for k=2 or 2414961.935157746 for k=-2
Function NewMoon(ByVal k As Long) As Double    Dim T As Double, T2 As Double, T3 As Double, dr As Double    Dim Jd1 As Double, m As Double, Mpr As Double    Dim F As Double, C1 As Double, deltat As Double, JdNew As Double    T = k / 1236.85 ' Time in Julian centuries from 1900 January 0.5    T2 = T * T    T3 = T2 * T    dr = PI / 180    Jd1 = 2415020.75933 + 29.53058868 * k + 0.0001178 * T2 - 0.000000155 * T3    Jd1 = Jd1 + 0.00033 * Sin((166.56 + 132.87 * T - 0.009173 * T2) * dr)        ' Mean new moon    m = 359.2242 + 29.10535608 * k - 0.0000333 * T2 - 0.00000347 * T3        ' Sun's mean anomaly    Mpr = 306.0253 + 385.81691806 * k + 0.0107306 * T2 + 0.00001236 * T3        ' Moon's mean anomaly    F = 21.2964 + 390.67050646 * k - 0.0016528 * T2 - 0.00000239 * T3        ' Moon's argument of latitude    C1 = (0.1734 - 0.000393 * T) * Sin(m * dr) + 0.0021 * Sin(2 * dr * m)    C1 = C1 - 0.4068 * Sin(Mpr * dr) + 0.0161 * Sin(dr * 2 * Mpr)    C1 = C1 - 0.0004 * Sin(dr * 3 * Mpr)    C1 = C1 + 0.0104 * Sin(dr * 2 * F) - 0.0051 * Sin(dr * (m + Mpr))    C1 = C1 - 0.0074 * Sin(dr * (m - Mpr)) + 0.0004 * Sin(dr * (2 * F + m))    C1 = C1 - 0.0004 * Sin(dr * (2 * F - m)) - 0.0006 * Sin(dr * (2 * F + Mpr))    C1 = C1 + 0.001 * Sin(dr * (2 * F - Mpr)) + 0.0005 * Sin(dr * (2 * Mpr + m))    If (T < -11) Then        deltat = 0.001 + 0.000839 * T + 0.0002261 * T2 _                - 0.00000845 * T3 - 0.000000081 * T * T3    Else        deltat = -0.000278 + 0.000265 * T + 0.000262 * T2    End If    JdNew = Jd1 + C1 - deltat    NewMoon = JdNewEnd Function
' Compute the longitude of the sun at any time.' Parameter: floating number jdn, the number of days since 1/1/4713 BC noon
Function SunLongitude(ByVal jdn As Double) As Double    Dim T As Double, T2 As Double, dr As Double, m As Double    Dim L0 As Double, DL As Double, L As Double    T = (jdn - 2451545) / 36525        ' Time in Julian centuries from 2000-01-01 12:00:00 GMT    T2 = T * T    dr = PI / 180 ' degree to radian    m = 357.5291 + 35999.0503 * T - 0.0001559 * T2 - 0.00000048 * T * T2        ' mean anomaly, degree    L0 = 280.46645 + 36000.76983 * T + 0.0003032 * T2        ' mean longitude, degree    DL = (1.9146 - 0.004817 * T - 0.000014 * T2) * Sin(dr * m)    DL = DL + (0.019993 - 0.000101 * T) * Sin(dr * 2 * m) _        + 0.00029 * Sin(dr * 3 * m)    L = L0 + DL ' true longitude, degree    L = L * dr    L = L - PI * 2 * (Fix(L / (PI * 2))) ' Normalize to (0, 2*PI)    SunLongitude = LEnd Function
' Compute sun position at midnight of the day with the given Julian day number.' The time zone if the time difference between local time and UTC: 7.0 for UTC+7:00.' The function returns a number between 0 and 11.' From the day after March equinox and the 1st major term after March equinox,' 0 is returned. After that, return 1, 2, 3 ...Function getSunLongitude(ByVal dayNumber As Double, ByVal timeZone As Byte) As Long    getSunLongitude = Fix(SunLongitude(dayNumber - 0.5 - timeZone / 24) / PI * 6)End Function
' Compute the day of the k-th new moon in the given time zone.' The time zone if the time difference between local time and UTC: 7.0 for UTC+7:00Function getNewMoonDay(ByVal k As Long, ByVal timeZone As Long) As Long    getNewMoonDay = Fix(NewMoon(k) + 0.5 + timeZone / 24)End Function
' Find the day that starts the luner month 11 of the given year' for the given time zoneFunction getLunarMonth11(ByVal yy As Long, ByVal timeZone As Long) As Long    Dim k As Long, off As Double, nm As Long, sunLong As Double    '' off = jdFromDate(31, 12, yy) - 2415021.076998695    off = jdFromDate(31, 12, yy) - 2415021    k = Fix(off / 29.530588853)    nm = getNewMoonDay(k, timeZone)    sunLong = getSunLongitude(nm, timeZone) ' sun longitude at local midnight    If (sunLong >= 9) Then        nm = getNewMoonDay(k - 1, timeZone)    End If    getLunarMonth11 = nmEnd Function
' Find the index of the leap month after the month starting on the day a11.Function getLeapMonthOffset(ByVal a11 As Double, ByVal timeZone As Long) As Long    Dim k As Long, last As Long, Arc As Long, I As Long    k = Fix((a11 - 2415021.07699869) / 29.530588853 + 0.5)    last = 0    I = 1 ' We start with the month following lunar month 11    Arc = getSunLongitude(getNewMoonDay(k + I, timeZone), timeZone)    Do        last = Arc        I = I + 1        Arc = getSunLongitude(getNewMoonDay(k + I, timeZone), timeZone)    Loop While (Arc <> last And I < 14)    getLeapMonthOffset = I - 1End Function
' Comvert solar date dd/mm/yyyy to the corresponding lunar dateFunction Solar2Lunar( _        ByVal dd As Long, _        ByVal mm As Long, _        Optional ByVal yy As Long = 0, _        Optional ByVal timeZone As Long = 7) As String    Dim k As Long, diff As Long, leapMonthDiff As Long, dayNumber As Long    Dim monthStart As Double, a11 As Long, b11 As Long    Dim lunarDay As Double, lunarMonth As Long, lunarYear As Long, lunarLeap As Long    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~    If yy = 0 Then yy = Year(Date)    dayNumber = jdFromDate(dd, mm, yy)    k = Fix((dayNumber - 2415021.07699869) / 29.530588853)    monthStart = getNewMoonDay(k + 1, timeZone)    If (monthStart > dayNumber) Then        monthStart = getNewMoonDay(k, timeZone)    End If    ' alert(dayNumber + " -> " + monthStart)    a11 = getLunarMonth11(yy, timeZone)    b11 = a11    If (a11 >= monthStart) Then        lunarYear = yy        a11 = getLunarMonth11(yy - 1, timeZone)    Else        lunarYear = yy + 1        b11 = getLunarMonth11(yy + 1, timeZone)    End If    lunarDay = dayNumber - monthStart + 1    diff = Fix((monthStart - a11) / 29)    lunarLeap = 0    lunarMonth = diff + 11    If (b11 - a11 > 365) Then        leapMonthDiff = getLeapMonthOffset(a11, timeZone)        If (diff >= leapMonthDiff) Then            lunarMonth = diff + 10            If (diff = leapMonthDiff) Then lunarLeap = 1        End If    End If    If (lunarMonth > 12) Then lunarMonth = lunarMonth - 12    If (lunarMonth >= 11 And diff < 4) Then lunarYear = lunarYear - 1    Solar2Lunar = Format(lunarDay, "00") & _                "/" & Format(lunarMonth, "00") & _                "/" & Format(lunarYear, "0000 \A\L") & IIf(lunarLeap, " (" & lunarMonth & " N)", "")End Function
' Convert a lunar date to the corresponding solar dateFunction Lunar2Solar( _        ByVal lunarDay As Long, _        ByVal lunarMonth As Long, _        Optional ByVal lunarYear As Long = 0, _        Optional ByVal lunarLeap As Long = 0, _        Optional ByVal timeZone As Long = 7) As Date    Dim k As Long, a11 As Long, b11 As Long, off As Long, leapOff As Long    Dim LeapMonth As Long, monthStart As Long    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~    If lunarYear = 0 Then lunarYear = Year(Date)    If (lunarMonth < 11) Then        a11 = getLunarMonth11(lunarYear - 1, timeZone)        b11 = getLunarMonth11(lunarYear, timeZone)    Else        a11 = getLunarMonth11(lunarYear, timeZone)        b11 = getLunarMonth11(lunarYear + 1, timeZone)    End If    k = Fix(0.5 + (a11 - 2415021.07699869) / 29.530588853)    off = lunarMonth - 11    If (off < 0) Then off = off + 12    If (b11 - a11 > 365) Then        leapOff = getLeapMonthOffset(a11, timeZone)        LeapMonth = leapOff - 2        If (LeapMonth < 0) Then LeapMonth = LeapMonth + 12        If (lunarLeap <> 0 And lunarMonth <> LeapMonth) Then            Lunar2Solar = Array(0, 0, 0)            Exit Function        ElseIf (lunarLeap <> 0 Or off >= leapOff) Then            off = off + 1        End If    End If    monthStart = getNewMoonDay(k + off, timeZone)    Dim R    R = jdToDate(monthStart + lunarDay - 1)    Lunar2Solar = DateSerial(R(2), R(1), R(0))End Function                                    Function AmLich(d as Date)    AmLich = Solar2Lunar(day(d),month(d),year(d))end Function

Kết luận