Excel VBA テクニック集 |
|
Excelに依存しない日付関数(DateSerial)です。
昔、OSの理由のため、2000年問題・201?年問題がありましたが、私は下記プログラムを使うことにより回避できました。
(注:以前はCobolプログラムで使ってました。) 計算方法はグレゴリオ暦を基準にした方法で、西暦1年1月1日からある特定の日付までの日数、西暦1年1月1日から日数後の日付を算出します。 なお、西暦1年1月1日についてですが、1500年頃まではユリウス暦その後グレゴリオ暦ですので、計算上の西暦1年1月1日と実際の西暦1年1月1日とは違います。 Public Type Day_Def yy As Integer mm As Integer dd As Integer End Type Public Function Date_010101_Day(Nissu_F As Long) As Day_Def '西暦1年1月1日からの日数で日付に変換 Dim Nissu_W As Long Dim YY400_W As Long Dim AM400_W As Long Dim YY100_W As Long Dim AM100_W As Long Dim YYSyo_W As Long Dim AMSyo_W As Long Dim Nissu_T(12) As Integer Dim Amari_W As Integer Dim I As Integer Nissu_W = Nissu_F YY400_W = Int(Nissu_W / 146097) AM400_W = Nissu_W - YY400_W * 146097 YY100_W = Int(AM400_W / 36524) AM100_W = AM400_W - YY100_W * 36524 YYSyo_W = Int(AM100_W / 1461) AMSyo_W = AM100_W - YYSyo_W * 1461 Date_010101_Day.yy = Int(AMSyo_W / 365) Nissu_W = AMSyo_W - Date_010101_Day.yy * 365 Date_010101_Day.yy = Date_010101_Day.yy _ + YY400_W * 400 _ + YY100_W * 100 _ + YYSyo_W * 4 If AM400_W = 0 Then Date_010101_Day.mm = 12 Date_010101_Day.dd = 31 Exit Function End If If AM400_W = 146096 Then Date_010101_Day.mm = 12 Date_010101_Day.dd = 30 Exit Function End If If AMSyo_W = 0 Then Date_010101_Day.mm = 12 Date_010101_Day.dd = 31 Exit Function End If If AMSyo_W = 1460 Then Date_010101_Day.mm = 12 Date_010101_Day.dd = 30 Exit Function End If If Nissu_W = 0 Then Date_010101_Day.mm = 12 Date_010101_Day.dd = 31 Exit Function End If Date_010101_Day.yy = Date_010101_Day.yy + 1 Nissu_T(1) = 31 Nissu_T(2) = 28 Nissu_T(3) = 31 Nissu_T(4) = 30 Nissu_T(5) = 31 Nissu_T(6) = 30 Nissu_T(7) = 31 Nissu_T(8) = 31 Nissu_T(9) = 30 Nissu_T(10) = 31 Nissu_T(11) = 30 Nissu_T(12) = 31 Amari_W = Date_010101_Day.yy - Int(Date_010101_Day.yy / 4) * 4 If Amari_W = 0 Then Nissu_T(2) = 29 End If Amari_W = Date_010101_Day.yy - Int(Date_010101_Day.yy / 100) * 100 If Amari_W = 0 Then Nissu_T(2) = 28 End If Amari_W = Date_010101_Day.yy - Int(Date_010101_Day.yy / 400) * 400 If Amari_W = 0 Then Nissu_T(2) = 29 End If For I = 1 To 11 Date_010101_Day.mm = I If Nissu_W <= Nissu_T(I) Then Date_010101_Day.dd = Nissu_W Exit Function Else Nissu_W = Nissu_W - Nissu_T(I) End If Next I Date_010101_Day.mm = 12 Date_010101_Day.dd = Nissu_W End Function Public Function Date_010101_Nissu(YY_F As Integer _ , Mm_F As Integer _ , DD_F As Integer) As Long '日付を西暦1年1月1日からの日数に変換 Dim YY_W As Integer Dim MM_W As Integer Dim Dd_W As Integer Dim M30_6 As Currency Dim M30_6_W As Currency Dim YY100_W As Currency Dim YY400_W As Currency YY_W = YY_F MM_W = Mm_F Dd_W = DD_F If MM_W < 1 Then Do Until MM_W >= 1 YY_W = YY_W - 1 MM_W = MM_W + 12 Loop End If If MM_W > 12 Then Do Until MM_W <= 12 YY_W = YY_W + 1 MM_W = MM_W - 12 Loop End If If MM_W < 3 Then YY_W = YY_W - 1 MM_W = MM_W + 9 Else MM_W = MM_W - 3 End If M30_6 = MM_W * 30.6 M30_6_W = M30_6 - Int(M30_6) If M30_6_W < 0.5 Then M30_6 = Int(M30_6) Else M30_6 = Int(M30_6) + 1 End If YY100_W = Int(YY_W / 100) YY400_W = Int(YY_W / 400) Date_010101_Nissu = Int(YY_W * 365.25) _ + M30_6 + YY400_W + Dd_W _ - YY100_W - 306 End Function |
「こだわりハウス」写真館| 数学公式集| ピンポイントストリートビュー| FaceBook| Excel Vba テクニック集| Excel 計算式解析・他解析| 富山の建築家| Excel 計算式解析・他解析| 積分の定義・積分の記号の意味の研究| |