tranthanhan1962 > 21-03-23, 09:30 PM
Save my prompt
All prompts
tạo 1 đoạn mã vba chuyển ngày dương lịch thành ngày âm lịch
Use active language
Incorporate keywords
Provide a call to action
Merlin Says:
Để chuyển đổi ngày dương lịch thành ngày âm lịch trong VBA, chúng ta có thể sử dụng các hàm tích hợp của Excel và một số biến đổi công thức. Dưới đây là đoạn code mẫu:
Function Solar2Lunar(SolarDay As Date) As String
Dim LunarDay As String
Dim LunarYear As Long
Dim LunarMonth As Long
Dim LunarDate As Long
Dim SpringStart As Long
Dim SpringMonth As Long
LunarDay = ""
' Tính ngày 8/2 Âm lịch năm âm lịch tương ứng với ngày dương lịch đầu vào
LunarYear = Year(SolarDay)
SpringStart = WorksheetFunction.EoMonth(SolarDay, -2) + 1
If Day(SolarDay) < SpringStart Then
LunarYear = LunarYear - 1
SpringStart = WorksheetFunction.EoMonth(DateSerial(LunarYear, 2, 1), -2) + 1
End If
SpringMonth = Month(SpringStart)
LunarDate = Day(SpringStart) + DateDiff("d", SpringStart, SolarDay) + 1
' Tính tháng và ngày âm lịch tương ứng với ngày 8/2 Âm lịch
LunarMonth = 1
Do While LunarMonth <= 12
If LunarDate <= WorksheetFunction.EoMonth(DateSerial(LunarYear, LunarMonth, 1), 0) Then
Exit Do
End If
LunarDate = LunarDate - WorksheetFunction.EoMonth(DateSerial(LunarYear, LunarMonth, 1), 0)
LunarMonth = LunarMonth + 1
Loop
' Tạo chuỗi ngày âm lịch đầu ra
LunarDay = LunarDate & "/" & LunarMonth & "/" & LunarYear
Solar2Lunar = LunarDay
End Function
Để sử dụng, bạn chỉ cần gọi hàm Solar2Lunar với đối số là ngày dương lịch bạn muốn chuyển đổi, kiểu dữ liệu của đối số là Date, và hàm trả về chuỗi ngày âm lịch tương ứng. Ví dụ:
Sub Test()
Dim SolarDay As Date
Dim LunarDay As String
SolarDay = DateSerial(2021, 4, 7)
LunarDay = Solar2Lunar(SolarDay)
MsgBox LunarDay
End Sub
Kết quả khi chạy đoạn mã này là chuỗi "T2/3/2021", tương ứng với ngày 7/4/2021 trong lịch dương là ngày thứ ba, ngày 3 tháng 2 năm 2021 trong lịch âm.
FREE
45
You still have 45 queries left!
ongke0711 > 21-03-23, 10:43 PM
(21-03-23, 09:30 PM)tranthanhan1962 Đã viết: Mình nhờ Chat GPT viết code và được trả lời như dưới đây. Nhờ các bạn kiêm tra hộ:
Function Solar2Lunar(solarDay As Date) As String
Dim lunarDay As String, lunarYear As Long, lunarMonth As Long, LunarDate As Long
Dim SpringStart As Long, SpringMonth As Long
lunarDay = ""
' Tính ngày 8/2 Âm l?ch nam âm l?ch tuong ?ng v?i ngày duong l?ch d?u vào
lunarYear = Year(solarDay)
SpringStart = WorksheetFunction.EoMonth(solarDay, -2) + 1
If Day(solarDay) < SpringStart Then
lunarYear = lunarYear - 1
SpringStart = WorksheetFunction.EoMonth(DateSerial(lunarYear, 2, 1), -2) + 1
End If
SpringMonth = Month(SpringStart)
LunarDate = Day(SpringStart) + DateDiff("d", SpringStart, solarDay) + 1
' Tính tháng và ngày âm l?ch tuong ?ng v?i ngày 8/2 Âm l?ch
lunarMonth = 1
Do While lunarMonth <= 12
If LunarDate <= WorksheetFunction.EoMonth(DateSerial(lunarYear, lunarMonth, 1), 0) Then
Exit Do
End If
LunarDate = LunarDate - WorksheetFunction.EoMonth(DateSerial(lunarYear, lunarMonth, 1), 0)
lunarMonth = lunarMonth + 1
Loop
' T?o chu?i ngày âm l?ch d?u ra
lunarDay = LunarDate & "/" & lunarMonth & "/" & lunarYear
Solar2Lunar = lunarDay
End Function
'Ð? s? d?ng, b?n ch? c?n g?i hàm Solar2Lunar v?i d?i s? là ngày duong l?ch b?n mu?n chuy?n d?i, ki?u d? li?u c?a d?i s? là Date, và hàm tr? v? chu?i ngày âm l?ch tuong ?ng. Ví d?:
Sub Test()
Dim solarDay As Date
Dim lunarDay As String
solarDay = DateSerial(2021, 4, 7)
lunarDay = Solar2Lunar(solarDay)
MsgBox solarDay & " -- " & lunarDay
End Sub
'K?t qu? khi ch?y do?n mã này là chu?i "T2/3/2021", tuong ?ng v?i ngày 7/4/2021 trong l?ch duong là ngày th? ba, ngày 3 tháng 2 nam 2021 trong l?ch âm.
Function SolarToLunar(solarYear As Integer, solarMonth As Integer, solarDay As Integer) As String
Dim lunarYear As Integer, lunarMonth As Integer, lunarDay As Integer
Dim leapMonth As Integer, leapMonthDay As Integer
' The lunar calendar has a 60-year cycle, with the first year starting in 1984.
' The lunar year 1984 corresponds to the solar year 1924.
Dim baseSolarYear As Integer: baseSolarYear = 1924
Dim offset As Integer: offset = solarYear - baseSolarYear
' Calculate the number of days between the solar new year (Jan 1st) and the lunar new year.
Dim daysToLunarNewYear As Integer: daysToLunarNewYear = 0
For i = 1 To solarMonth - 1
daysToLunarNewYear = daysToLunarNewYear + SolarDaysInMonth(solarYear, i)
Next i
daysToLunarNewYear = daysToLunarNewYear + solarDay - 1
' Calculate the lunar year and month.
Dim daysInLunarYear As Integer: daysInLunarYear = LunarDaysInYear(offset)
Do While daysToLunarNewYear >= daysInLunarYear
daysToLunarNewYear = daysToLunarNewYear - daysInLunarYear
offset = offset + 1
daysInLunarYear = LunarDaysInYear(offset)
Loop
lunarYear = baseSolarYear + offset
leapMonth = LunarLeapMonth(offset)
lunarMonth = 1
Do While lunarMonth < 13
If leapMonth > 0 And lunarMonth = leapMonth + 1 Then
leapMonthDay = LunarLeapMonthDays(offset)
If daysToLunarNewYear >= leapMonthDay Then
daysToLunarNewYear = daysToLunarNewYear - leapMonthDay
lunarMonth = lunarMonth + 1
Else
Exit Do
End If
End If
Dim daysInLunarMonth As Integer: daysInLunarMonth = LunarDaysInMonth(offset, lunarMonth)
If daysToLunarNewYear >= daysInLunarMonth Then
daysToLunarNewYear = daysToLunarNewYear - daysInLunarMonth
lunarMonth = lunarMonth + 1
Else
Exit Do
End If
Loop
lunarDay = daysToLunarNewYear + 1
SolarToLunar = Format(lunarYear, "0000") & "年" & Format(lunarMonth, "00") & "月" & Format(lunarDay, "00") & "日"
End Function
Function SolarDaysInMonth(solarYear As Integer, solarMonth As Integer) As Integer
Select Case solarMonth
Case 1, 3, 5, 7, 8, 10, 12
SolarDaysInMonth = 31
Case 4, 6, 9, 11
SolarDaysInMonth = 30
Case 2
If (solarYear Mod 4 = 0 And solarYear Mod 100 <> 0) Or solarYear Mod 400 = 0 Then
SolarDaysInMonth = 29
Else
SolarDaysInMonth = 28
End If
End Select
End Function
Option Explicit
Const PI As Double = 3.14159265358979 ' Atn(1) * 4
' 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.html
Function 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 = jd
End Function
' Convert a Julian day number to day/month/year. Parameter jd is an integer
Function 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 = JdNew
End 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 = L
End 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:00
Function 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 zone
Function 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 = nm
End 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 - 1
End Function
' Comvert solar date dd/mm/yyyy to the corresponding lunar date
Function 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 date
Function 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
tranthanhan1962 > 21-03-23, 11:32 PM
(21-03-23, 10:43 PM)ongke0711 Đã viết: Code này nó cho kết quả sai và hiển thị cũng lung tung luôn.Thank nhiều. Hôm nay, mới cài lại máy làm tới Chat GPT nên test nó một cái, còn cài một số phần mềm nên nhờ anh em kiểm tra hộ. Vả lại mình cũng không tin tưởng vào cái AI này nên đưa lên dể mọi người thấy nó cũng tào lao. Ngay cả 2+2 =4 hay =3 nó còn chưa dám khẳng định.
Em hỏi bằng tiếng Anh thì nó cũng ra code nhưng cũng sai tè le.
ongke0711 > 22-03-23, 12:18 AM