Excel VBA テクニック集
Excelに依存しない日付関数(DateSerialに相当)





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 計算式解析・他解析| 積分の定義・積分の記号の意味の研究|