Tạo lịch năm bằng hàm match, index

[zinzin8x]

Anh ThuNghi ơi ới ời... hôm này là 26/12 rồi anh ơi, anh làm lại chưa ?

Tính làm mà thấy file của LearnExcel hay quá nên thôi, với lại dạo này làm biếng quá, cuối năm bận quá.

[phimdaitao]

' CÁC BẠN DÙNG THỬ ĐOẠN MÃ SAU
' COPY VÀ DÁN VÀO 1 MODUL BẤT KỲ TRÊN VBA
' CÁCH DÙNG: VÍ DỤ: Solar2lunar(01,01,2009,7) số cuối là múi giờ


Option Explicit
Const PI As Double = 3.14159265358979


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


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
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


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
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)
m = 359.2242 + 29.10535608 * k - 0.0000333 * T2 - 0.00000347 * T3
Mpr = 306.0253 + 385.81691806 * k + 0.0107306 * T2 + 0.00001236 * T3
F = 21.2964 + 390.67050646 * k - 0.0016528 * T2 - 0.00000239 * T3
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

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
T2 = T * T
dr = PI / 180
m = 357.5291 + 35999.0503 * T - 0.0001559 * T2 - 0.00000048 * T * T2
L0 = 280.46645 + 36000.76983 * T + 0.0003032 * T2
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
L = L * dr
L = L - PI * 2 * (Fix(L / (PI * 2)))
SunLongitude = L
End Function

Function getSunLongitude(ByVal dayNumber As Double, ByVal timeZone As Byte) As Long
getSunLongitude = Fix(SunLongitude(dayNumber - 0.5 - timeZone / 24) / PI * 6)
End Function

Function getNewMoonDay(ByVal k As Long, ByVal timeZone As Long) As Long
getNewMoonDay = Fix(NewMoon(k) + 0.5 + timeZone / 24)
End Function

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
k = Fix(off / 29.530588853)
nm = getNewMoonDay(k, timeZone)
sunLong = getSunLongitude(nm, timeZone)
If (sunLong >= 9) Then
nm = getNewMoonDay(k - 1, timeZone)
End If
getLunarMonth11 = nm
End Function

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
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

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
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

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 = Date******(R(2), R(1), R(0))
End Function

[thanhtruc02]

Anh ThuNghi ơi!

Đã có file hòan chỉnh chưa?

Rgds
TH

[lebachit]

Chào ThuNghi,
File của bạn rất hay. Mình muốn hỏi về việc chọn năm trong sheet "Lịch Thang", cụ thể mình muốn thêm năm 2013 thì phải vào đâu đế thay đổi, Trong file này hạn chế đến năm 2012 thôi. Cám ơn nhiều.

[duongsarah]

Cám ơn bạn. Làm thế nào để có được lịch của những năm tiếp theo?

[aloxinh]

Tôi có tải được một file làm lịch nhìn có vẻ đơn giản nhưng tôi vẫn không hiểu được dụng ý của việc lập bảng từ ô A1 -> AA6. Có ai biết gì không chỉ giúp tôi và giải thích cho tôi hiểu với. Cảm ơn các bạn nhiều![IMG]images/smilies/a43.gif[/IMG]

[aaronmax]

Quả là rất hay, giờ mới tò mò đọc và tìm hiểu. Nhưng hơi tiếc là giới hạn thời gian quá. Bài này chắc làm lâu lắm rồi nên ở thời gian hiện tại bị lỗi [IMG]images/smilies/a12.gif[/IMG]