LoginSignup
0
1

More than 3 years have passed since last update.

@Q11Q

Excel VBA 2018年以降の日本の祝日を作り出して稼働日、営業日数を NetworkDays.INTL Workdays.INTLで計算させるマクロ

Last updated at Posted at 2019-10-05

https://docs.microsoft.com/en-us/office/vba/api/Excel.WorksheetFunction.NetworkDays_Intl
https://docs.microsoft.com/en-us/office/vba/api/excel.worksheetfunction.workday_intl
NetWorkdays.INTLは以前発見したように正確な日数計算ができます。
[EXCELでは論文を書けない]エクセルで閏年を含めた日数計算を簡単に行う方法 How to calculate Date Diff Inclued Leap Year with Excel

行列 A B C
1 2016/1/1 2016/12/31 =NETWORKDAYS.INTL(A1,B1,"0000000")

NetWorkdays.Intlは2つの日付の間の日数を計算し、Workdays.Intlは起算日から休日、祝祭日を除いた何日後（何日前）の日付を求める関数です。

この２つの関数はともに第4の引数を有しています。

Variant Holidays - An optional set of one or more dates that are to be excluded from the working day calendar. Holidays is a range of cells that contain the dates, or an array constant of the serial values that represent those dates. The ordering of dates or serial values in holidays can be arbitrary.
休日 省略可能です。 稼働日の予定表から除外する日付のセットです。 休日の日付は、休日を表す日付が含まれたセル範囲またはシリアル値の配列定数として指定できます。 休日の日付またはシリアル値は、任意の順序で指定できます。

この２つの関数は祝日をリストにして名前を付けた範囲を定める必要があります。
このシートをHolidayJPとしてそこに作り出すVBAが下記のとおりです。
現在2018年からしか計算できません。
この２つの関数は稼働日を求めるために非常に重要な関数ですが、その反面、日本の休日をリスト化しないと使えないという弱点があります。
次にこのリストは
祝日名、祝日、祝日名
という構成になっています。
これはVlookUpを使用する場合、B列を1列目とすると、祝日から、祝日名を求めることができます。
これは年間カレンダーを作る場合に祝日かどうか、祝日名が何かを判定できます。
多少わかりやすさを重視して、本来のものと表記が異なる場合があります。そういう場合はReplaceで対応してください。
基本的に祝日は2年先までしかわかりません。
春分の日や秋分の日は実際は天体観測をして決まるため、計算で求めるとずれるからです。
したがって、このマクロは常に見直す必要があります。

Excelの設定例

NetworkDays.INTL

行列 A B C
1 2019/1/1 2019/12/31 =NETWORKDAYS.INTL(A1,B1,1,HolidayJPList)
行列 A B C
1 2019/1/1 2019/12/31 =NETWORKDAYS.INTL(A1,B1,1,HolidayJP!HolidayJPList)
2 2019/1/1 =WORKDAY.INTL(A2,111,1,HolidayJP!HolidayJPList) '2019/1/1から111日後の平日

VLookUpで祝祭日の名前を返す

=VLOOKUP(DATE(2019,10,14),HolidayJP!B1:C100,2,False)
ここで範囲の名前を用いる
=VLOOKUP(DATE(2019,10,14),HolidayJP!VLUpHolidayJP,2,False)
Trueだと間違った値が返ります。失礼しました。Falseが正しいです。
=IF(ISERROR(VLOOKUP(DATE(2019,10,14),HolidayJP!VLUpHolidayJP,2,FALSE)),"",VLOOKUP(DATE(2019,10,14),HolidayJP!VLUpHolidayJP,2,FALSE))
該当しないと#N/Aエラーになるため、エラー判定をします。

ExcelのVlookUp、Workdays.INTL,NetWorkDays.INTLで範囲の名前を使うのがなぜ有効か

この範囲の名前は動的に拡張されます。
例えば現在リストができている場合、1つ追加したい場合は途中の行に挿入する形で追加し、並べ替えを行うと名前の範囲が自動的に変更されます。
Excel ワークシートで動的な定義済みの範囲を作成する方法
今回のシートのVLUpHolidayJpは1列目が日付(Double)、2列目がテキストになっている。

CountとCountAの違い

この場合、最後の行はCountAではなくCountになる
そうしないと2倍の行数が返ってくる。1列目と2列目を文字列扱いして計算するようだ。

Offsetの解説

=OFFSET(HolidayJP!\$B\$1,0,0,COUNT(HolidayJP!\$B\$1:\$B188),1)
本当はB1でよいが、シートが変わっている場合を考えワークシート名！としている
また基準のセルなので、左上端のセルを一つ参照すればよい
=OFFSET(HolidayJP!\$B\$1,0,0,COUNT(HolidayJP!\$B\$1:\$B188),1)
この0，0はB1をずらすときに使う。しかし通常は基準点は素直に入れているので常識的に0,0.が入ってくる
=OFFSET(HolidayJP!\$B\$1,0,0,COUNT(HolidayJP!\$B\$1:\$B188),1)
CountがLastrowに匹敵する。B1:B*188*1行目からだとわかりづらいが、ここが行数になる。
=OFFSET(HolidayJP!\$B\$1,0,0,COUNT(HolidayJP!\$B\$1:\$B188),1)

=OFFSET(HolidayJP!$B$1,0,0,COUNT(HolidayJP!$B$1:$C188),2)
最後の1が行数になる VLUpHolidayJpが2であるのに対して、1が入っている。
VlUpHolidayはB列とC列を使うため2になっている。
なので本当はVlUpHolidayListのCountもCOUNT(HolidayJP!$B$1:$B188)でよい。

名前定義の活用

Excel2010以降(の入力規則のリスト)は、別シートの参照範囲も設定できるようになりました。
データの入力規則
(入力規則のリスト設定画面で) Excel2007まではここでシートの切り替えができませんでした。

動的名前範囲は設定レベルに注意する

手動で設定する場合には必ず設定するワークシートを表示しないと動的名前のレベルがワークブックになります
すると、別のシートで参照すると
=IF(ISERROR(VLOOKUP(DATE(2019,10,14),MakeJpnHolidaylistxlsm.xlsm!VLUpHolidayJP,2,FALSE)),"",VLOOKUP(DATE(2019,10,14),MakeJpnHolidaylistxlsm.xlsm!VLUpHolidayJP,2,FALSE))
とこのようにブック名!範囲名になります。
このように一度使われていると、これをワークシートレベルに戻そうとして削除しようとします。

For Each xName In wb.Names
    If xName = VlookUpRngName _
     Then xName.Delete: Exit For
Next

これでも消えない可能性があります。
また仮にこれを消去してワークシートレベルで参照範囲を設定しても、数式を変更しないとエラーになる場合があります。

Outlookでも

Outlookに予定表を作成するマクロを組む場合、平日の稼働日数で計算して日付を定める場合にExcel表で日付を計算して作り出す方法があります。このときにNetWorkDays.Intl,Workdays.Intlを使います。またここで末日を求めるテクニック、第1週、第2週～第5週を求める手法が定期的な予定の変わりに使うときがあります。

Option Explicit
Const TgtSheet As String = "HolidayJP"
Const RngName As String = "HolidayJPList"
Const VlookUpRngName As String = "VLUpHolidayJP" '2019/10/06 Change Name
Const JpGovClose = "官公庁閉庁日"
Const 天皇誕生日2018 As Date = #12/23/2018#
Const 天皇誕生日2020 As Date = #2/23/2020#
Const Jpn_EmperorsBirthDay1989_2018 As Date = #12/23/2018#
Const Jpn_EmperorsBirthDay2020 As Date = #2/23/2020#
Const JpnSportsday2020 As Date = #7/24/2020#
Const NationalSeadayJpn2020 As Date = #7/23/2020#
Const JpnMontainday2020 As Date = #8/10/2020#
Const JpnGovermentClosed02 As Date = #1/2/2019#
Const JpnGovermentClosed03 As Date = #1/3/2019#
Const JpnGovermentClosed29 As Date = #12/29/2019#
Const JpnGovermentClosed30 As Date = #12/30/2019#
Const JpnGovermentClosed31 As Date = #12/31/2019#
Sub SetJapaneseHolidays2018later()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wss As Worksheets, ws As Worksheet
For Each ws In wb.Worksheets
If ws.Name = TgtSheet Then Exit For
Next
If ws Is Nothing Then Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count)): ws.Name = TgtSheet
Dim r As Range, URnge As Range
Dim iRow As Long, iCol As Long, cnt As Long, i1 As Long, LastRow As Long, LastCol As Long
Dim dt As Date, iyear As Integer, iMonth As Byte, iday As Byte
Dim ar(), ia As Long, bl As Boolean
Dim buf As String
Dim xName As Name, xNames As Names
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
ar = ws.Range("A1:B" & LastRow)
For iyear = 2018 To 2025

''’//// 1/1 //// '''
dt = CDate("1/1/" & iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "元旦"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "元旦"
End If
''’//// 1/2 //// '''
dt = CDate("1/2/" & iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = JpGovClose
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = JpGovClose
End If
''’//// 1/3 //// '''
dt = CDate("1/3/" & iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = JpGovClose
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = JpGovClose
End If
''’//// 12/29 //// '''
dt = CDate("29/12/" & iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = JpGovClose
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = JpGovClose
End If
''’//// 12/30 //// '''
dt = CDate("30/12/" & iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = JpGovClose
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = JpGovClose
End If
''’//// 12/31 //// '''
dt = CDate("31/12/" & iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = JpGovClose
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = JpGovClose
End If
''’//// 成人の日 //// '''
For iday = 8 To 14
dt = CDate(iyear & "/1/" & iday)
If Weekday(dt) = vbMonday Then
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "成人の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "成人の日"
Exit For
End If
End If
Next
''’//// 山の日 //// '''
If iyear = 2020 Then
dt = JpmMontainday2020
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "山の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "山の日"
End If
End If

If iyear <= 2019 Or iyear >= 2021 Then
dt = CDate(iyear & "/8/11")
bl = False
  For ia = LBound(ar) To UBound(ar)
    If dt = ar(ia, 2) Then bl = True: Exit For
  Next
  If bl = False Then
    LastRow = LastRow + 1
    ws.Range("A" & LastRow) = "山の日"
    ws.Range("B" & LastRow) = dt
    ws.Range("C" & LastRow) = "山の日"
  End If
  If Weekday(dt) = vbSunday Then
  dt = dt + 1
  bl = False
  For ia = LBound(ar) To UBound(ar)
    If dt = ar(ia, 2) Then bl = True: Exit For
  Next
  If bl = False Then
    LastRow = LastRow + 1
    ws.Range("A" & LastRow) = "山の日(振替休日)"
    ws.Range("B" & LastRow) = dt
    ws.Range("C" & LastRow) = "山の日(振替休日)"
  End If
  End If
End If
''’//// 5/3 //// '''
dt = CDate(iyear & "/5/3")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "憲法記念日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "憲法記念日"
End If
''’//// 5/4 //// '''
dt = CDate(iyear & "/5/4")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "みどりの日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "みどりの日"
End If
''’//// 5/5 //// '''
dt = CDate(iyear & "/5/5")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "子供の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "子供の日"
End If
''’//// 11/3 //// '''
dt = CDate(iyear & "/11/3")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "文化の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "文化の日"
End If

If Weekday(dt) = vbSunday Then
dt = dt + 1
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "文化の日(振替休日)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "文化の日(振替休日)"
End If
End If

''’//// 11/23 //// '''
dt = CDate(iyear & "/11/23")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "勤労感謝の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "勤労感謝の日"
End If

If Weekday(dt) = vbSunday Then
    dt = dt + 1
    bl = False
    For ia = LBound(ar) To UBound(ar)
        If dt = ar(ia, 2) Then bl = True: Exit For
    Next

    If bl = False Then
        LastRow = LastRow + 1
        ws.Range("A" & LastRow) = "勤労感謝の日(振替休日)"
        ws.Range("B" & LastRow) = dt
        ws.Range("C" & LastRow) = "勤労感謝の日(振替休日)"
    End If
End If
''’//// 秋分の日 //// '''
dt = fnAutumnEquinox1980_2099(iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "秋分の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "秋分の日"
End If

If Weekday(dt) = vbSunday Then
dt = dt + 1
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "秋分の日(振替休日)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "秋分の日(振替休日)"
End If
End If
''’//// 春分の日 //// '''
dt = fnSpringEquinox1980_2099(iyear)
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "春分の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "春分の日"
End If
If Weekday(dt) = vbSunday Then
dt = dt + 1
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "春分の日(振替休日)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "春分の日(振替休日)"
End If
End If
''’//// 建国記念の日 //// '''
dt = CDate(iyear & "/2/11")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "建国記念の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "建国記念の日"
End If
If Weekday(dt) = vbSunday Then
dt = dt + 1
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "建国記念の日(振替休日)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "建国記念の日(振替休日)"
End If
End If
''’//// スポーツの日 //// '''
If iyear <= 2019 Then
buf = "体育の日"
ElseIf iyear >= 2020 Then
buf = "スポーツの日"
End If

If iyear = 2020 Then
dt = JpnSportsday2020
bl = False
 For ia = LBound(ar) To UBound(ar)
  If dt = ar(ia, 2) Then bl = True: Exit For
 Next
If bl = False Then
  LastRow = LastRow + 1
  ws.Range("A" & LastRow) = buf
  ws.Range("B" & LastRow) = dt
  ws.Range("C" & LastRow) = buf
End If
End If
If (iyear <= 2019 And iyear >= 2000) Or iyear > 2020 Then
    For iday = 8 To 14
    dt = CDate(iyear & "/10/" & iday)
        If Weekday(dt) = vbMonday Then
          bl = False
           For ia = LBound(ar) To UBound(ar)
             If dt = ar(ia, 2) Then bl = True: Exit For
           Next
          If bl = False Then
            LastRow = LastRow + 1
            ws.Range("A" & LastRow) = buf
            ws.Range("B" & LastRow) = dt
            ws.Range("C" & LastRow) = buf
          Exit For
          End If
        End If
    Next
End If

''’//// 天皇誕生日(昭和) みどりの日 昭和の日 4/29 //// '''
dt = CDate(iyear & "/4/29")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "昭和の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "昭和の日"
End If
If Weekday(dt) = vbSunday Then
dt = CDate(iyear & "/4/30")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "昭和の日(振替休日)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "昭和の日(振替休日)"
End If
End If
''’//// 天皇誕生日(平成以降) //// '''
If iyear <= 2018 And iyear >= 1989 Then
dt = CDate(iyear & "/12/23")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "天皇誕生日(平成)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "天皇誕生日(平成)"
End If
If Weekday(dt) = vbSunday Then
dt = dt + 1
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "天皇誕生日(振替休日)(平成)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "天皇誕生日(振替休日)(平成)"
End If
End If
End If

If iyear >= 2020 Then
dt = CDate(iyear & "/2/23")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "天皇誕生日(令和)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "天皇誕生日(令和)"
End If
If Weekday(dt) = vbSunday Then
dt = dt + 1
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "天皇誕生日(振替休日)(令和)"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "天皇誕生日(振替休日)(令和)"
End If
End If
End If

''’//// 5/6 //// '''
dt = CDate("5/6/" & iyear)
If Weekday(dt - 3) = vbSunday Or _
Weekday(dt - 2) = vbSunday Or _
Weekday(dt - 1) = vbSunday Then
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "振替休日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "振替休日"

End If
End If


''’//// 敬老の日 //// '''
For iday = 15 To 21
dt = CDate(iyear & "/9/" & iday)
If Weekday(dt) = vbMonday Then
bl = False
    For ia = LBound(ar) To UBound(ar)
      If dt = ar(ia, 2) Then bl = True: Exit For
    Next
    If bl = False Then
    LastRow = LastRow + 1
    ws.Range("A" & LastRow) = "敬老の日"
    ws.Range("B" & LastRow) = dt
    ws.Range("C" & LastRow) = "敬老の日"
    Exit For
    End If
End If
Next

''' 2019
dt = CDate("2019/5/1")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "天皇の即位の日"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "天皇の即位の日"
End If
dt = CDate("2019/10/22")
bl = False
For ia = LBound(ar) To UBound(ar)
If dt = ar(ia, 2) Then bl = True: Exit For
Next
If bl = False Then
LastRow = LastRow + 1
ws.Range("A" & LastRow) = "即位礼正殿の儀"
ws.Range("B" & LastRow) = dt
ws.Range("C" & LastRow) = "即位礼正殿の儀"
End If
''’//// 海の日 //// '''
buf = "海の日"

If iyear = 2020 Then
dt = NationalSeadayJpn2020
bl = False
 For ia = LBound(ar) To UBound(ar)
  If dt = ar(ia, 2) Then bl = True: Exit For
 Next
If bl = False Then
  LastRow = LastRow + 1
  ws.Range("A" & LastRow) = buf
  ws.Range("B" & LastRow) = dt
  ws.Range("C" & LastRow) = buf
End If
End If

If iyear <= 2019 Or iyear >= 2020 Then
    For iday = 15 To 21
    dt = CDate(iyear & "/7/" & iday)
        If Weekday(dt) = vbMonday Then
          bl = False
           For ia = LBound(ar) To UBound(ar)
             If dt = ar(ia, 2) Then bl = True: Exit For
           Next
          If bl = False Then
            LastRow = LastRow + 1
            ws.Range("A" & LastRow) = buf
            ws.Range("B" & LastRow) = dt
            ws.Range("C" & LastRow) = buf
          Exit For
          End If
        End If
    Next
End If
Erase ar
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
ar = ws.Range("A1:B" & LastRow)

Next 'iYear
'''EXCELのバージョンごとの名前設定
' Office 2010 Later
If Application.Version >= 14 Then
If ws.Range("A1").Value = "" Then
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
End If
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Range("A1").Select
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Activate
    ws.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add2 Key:=Range( _
        "B1:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ws.Sort
        .SetRange Range("A1:C" & LastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
ws.Range("A1").Select

For Each xName In ws.Names
    If xName = RngName Then xName.Delete: Exit For
Next
For Each xName In ws.Names
    If xName = VlookUpRngName _
     Then xName.Delete: Exit For
Next
    Set xName = ws.Names.Add(Name:=RngName, Visible:=True, RefersToR1C1 _
        :="=" & TgtSheet & "!R1C2:R" & LastRow & "C2")
        xName.Comment = _
        "For Wokdays.Intl And NetWorkDays.Intl. Worksheet Level Range Name of Japanese Holiday List"
    Set xName = ws.Names.Add(Name:=VlookUpRngName, Visible:=True, RefersToR1C1 _
        :="=" & TgtSheet & "!R1C2:R" & LastRow & "C3")
    xName.Comment = _
        "For VlookUP Range Name of Japanese Holiday List"
ElseIf Application.Version = 12 Then
' Office 2007
    ws.Activate
    ws.Range("A1").Formula = "A Holiday List"
    ws.Range("B1").Formula = "=RAND()*0+10"
    ws.Range("C1").Formula = "A Holiday List"
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
Range("A2").Select
ws.Activate
    ws.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add2 Key:=Range( _
        "B2:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ws.Sort
        .SetRange Range("A2:C" & LastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
For Each xName In ws.Names
    If xName = RngName Then xName.Delete: Exit For
Next
For Each xName In ws.Names
    If xName = VlookUpRngName _
     Then xName.Delete: Exit For
Next
    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    Set xName = wb.Names.Add(Name:=RngName, RefersTo:="=OFFSET(" & TgtSheet & "!$B$1,0,0,COUNT(" & TgtSheet & "!$B$1:$B" & LastRow & "),1)")
    xName.Comment = "For Wokdays.Intl And NetWorkDays.Intl. Worksheet Level Range Name of Japanese Holiday List"
    buf = "": buf = "=OFFSET(" & TgtSheet & "!$B$1,0,0,COUNT(" & TgtSheet & "!$B$1:$C" & LastRow & "),2)"
    Set xName = ws.Names.Add(Name:=VlookUpRngName, Visible:=True, RefersTo:=buf)
        xName.Comment = _
        "For VlookUP Range Name of Japanese Holiday List"
Else
' Office 2003 Before
' Excel 2003は公式の説明ではこうなる(Excel2007同等)と考えられるが、範囲名がワークブックレベルかもしれない。要検証

    ws.Activate
    ws.Range("A1").Formula = "A Holiday List"
    ws.Range("B1").Formula = "=RAND()*0+10"
    ws.Range("C1").Formula = "A Holiday List"
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Range("A1").Select
    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Range("A2").Select
ws.Activate
    ws.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add2 Key:=Range( _
        "B2:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ws.Sort
        .SetRange Range("A2:C" & LastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
For Each xName In ws.Names
    If xName = RngName Then xName.Delete: Exit For
Next
For Each xName In ws.Names
    If xName = VlookUpRngName _
     Then xName.Delete: Exit For
Next
    Set xName = ws.Names.Add(Name:=RngName, RefersTo:="=OFFSET(" & TgtSheet & "!$B$1,0,0,COUNT(" & TgtSheet & "!$B$1:$C" & LastRow & "),1)")
    xName.Comment = "For Wokdays.Intl And NetWorkDays.Intl. Worksheet Level Range Name of Japanese Holiday List"
    buf = "": buf = "=OFFSET(" & TgtSheet & "!$B$1,0,0,COUNT(" & TgtSheet & "!$B$1:$C" & LastRow & "),2)"
    Set xName = ws.Names.Add(Name:=VlookUpRngName, Visible:=True, RefersTo:=buf)
        xName.Comment = _
        "For VlookUP Range Name of Japanese Holiday List"
End If ’ Application.Version >= 14 Then

End Sub
Function IsLeapYear2020Later(dt) As Boolean
Dim iyear As Long
On Error GoTo Err_Handle
iyear = Year(dt)
If Day(DateSerial(iyear, 3, 0)) = 29 Then
IsLeapYear2020Later = True
Else
IsLeapYear2020Later = False
End If
Exit Function
Err_Handle:
Debug.Print Err.Number, Err.Description
Err.Clear
IsLeapYear2020Later = False
End Function

Function fnSpringEquinox1980_2099(iyear) As Date
'https://oshiete.goo.ne.jp/qa/1454974.html
Debug.Print TypeName(iyear)
Dim i As Long
If TypeName(iyear) = "Date" Or TypeName(iyear) = "Integer" Or TypeName(iyear) = "Long" Or TypeName(iyear) = "Double" Then
Select Case TypeName(iyear)
Case Is = "Date"
i = Year(iyear)
Case Is = "Long"
i = iyear
Case Is = "Double"
i = CLng(iyear)
Case Is = "Integer"
i = CLng(iyear)
End Select
End If
If i > 1980 And i <= 2099 Then
Debug.Print Int(20.8431 + 0.242194 * (i - 1980) - Int((i - 1980) / 4))
'20.8431 整数部20は1980年3月の春分が20日
'0.8431 何時か世界時で11時05分 精度+-15分 UTC+9 20：05 +-15 がJTCの春分の時刻
' 0.242194 は 「 昔使われていた1年の日数 365.241294日 」 の小数点以下です。　要するに 毎年この端数（はすう）のぶん、日数が遅れてるのです
'カレンダーの方でも日数が遅れるのに合わせて「カレンダーを遅く」してますよね、4年に1回ずつ1日を加えてます。　そのぶん、上記の計算から「遅くした分」を引いてるのが　int((Y-1980)/4)
fnSpringEquinox1980_2099 = i & "/" & 3 & "/" & Int(20.8431 + 0.242194 * (i - 1980) - Int((i - 1980) / 4)): Exit Function
End If
End Function
Function fnAutumnEquinox1980_2099(iyear) As Date
Debug.Print TypeName(iyear)
Dim i As Long
If TypeName(iyear) = "Date" Or TypeName(iyear) = "Integer" Or TypeName(iyear) = "Long" Or TypeName(iyear) = "Double" Then
Select Case TypeName(iyear)
Case Is = "Date"
i = Year(iyear)
Case Is = "Long"
i = iyear
Case Is = "Double"
i = CLng(iyear)
Case Is = "Integer"
i = CLng(iyear)
End Select
End If
If i > 1980 And i <= 2099 Then
Debug.Print Int(20.8431 + 0.242194 * (i - 1980) - Int((i - 1980) / 4)):
fnAutumnEquinox1980_2099 = i & "/" & 9 & "/" & Int(23.2488 + 0.242194 * (i - 1980) - Int((i - 1980) / 4)): Exit Function
End If
End Function

Samplesheet

(Net)Worksdays.INTは入力が大変なのでSampleシートを作る
複数のシートがある場合、Sheet1をそのままにしておくとAccessibilityの問題があるということなので、Sampleに変える。

Sub HolidaySamplesheet()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet, wss As Excel.Sheets
Dim bl As Boolean
Set wss = wb.Sheets
bl = False
For Each ws In wss
If ws.Name = "Sheet1" Then ws.Name = "Sample" : bl = True: Exit For
If ws.Name = "Sample" Then bl = True: Exit For
Next
If bl = False Then Set ws = wb.Worksheets.Add(before:=wb.Worksheets(1))
ws.Name = "Sample"
ws.Activate
    Range("A1").FormulaR1C1 = "1/1/2019"
    Range("B1").FormulaR1C1 = "12/31/2019"
    Range("C1").FormulaR1C1 = _
        "=NETWORKDAYS.INTL(RC[-2],RC[-1],1,MakeJpnHolidaylistxlsm.xlsm!HolidayJPList)"
    Range("D1").FormulaR1C1 = _
        "=NETWORKDAYS.INTL(RC[-3],RC[-2],1,HolidayJP!HolidayJPList)"
    Range("C2").Value = "'2019/1/1から111日後の平日"
    Range("B2").FormulaR1C1 = "=WORKDAY.INTL(RC[-1],111,1,HolidayJP!HolidayJPList)"
    Range("A2").FormulaR1C1 = "1/1/2019"
    Range("D2").FormulaR1C1 = "=DAYS(""2017/1/1"",""2016/1/1"")"
    Range("E2").FormulaR1C1 = "=DAYS(31,29)"
    Range("F2").FormulaR1C1 = "=DATE(2019,1,1)"
    Range("G2").FormulaR1C1 = _
        "=IF(ISERROR(VLOOKUP(DATE(2019,10,14),HolidayJP!HolidayJPList,2,FALSE)),"""",VLOOKUP(DATE(2019,10,14),HolidayJP!VLUpHolidayJP,2,FALSE))"
    Range("H2").FormulaR1C1 = _
        "=VLOOKUP(DATEVALUE(""2020/7/23""),HolidayJP!VLUpHolidayJP,2,FALSE)"
        Range("E3").FormulaR1C1 = "'=DAYS(31,29)"
    Range("D3").FormulaR1C1 = "'=DAYS(""2017/1/1"",""2016/1/1"")"

    Columns("D:D").EntireColumn.AutoFit
    Range("G2").FormulaR1C1 = _
        "=IF(ISERROR(VLOOKUP(DATE(2019,10,14),HolidayJP!VLUpHolidayJP,2,FALSE)),"""",VLOOKUP(DATE(2019,10,14),HolidayJP!VLUpHolidayJP,2,FALSE))"
wb.Worksheets("HolidayJP").Activate
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "1/1/2018"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "12/31/2018"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "=NETWORKDAYS.INTL(RC[-2],RC[-1],1,HolidayJPList)"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(DATEVALUE(""2018/1/1""),VLUpHolidayJP,2,FALSE)"
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "=COUNT(R1C2:R188C2)"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(DATEVALUE(""2018/1/1""),VLUP,2,FALSE)"
    Range("G3").Select

End Sub

参考

春分の日や秋分の日を求めるには - wanichan
年間カレンダーの作成 - Excelでお仕事!
今月/前月/翌月の月末日を取得する - Moug
国立天文台　暦計算室

0
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
1