MyRibbonTools C00_MakeHolidaySht

【国民の祝日】シートを作成
（Microsoft365 64bit環境推奨）

　New Base Macro Book をコピーしてモジュールを追加して使用します

  1. 【Alt】＋【F11】キーを押下し、VBE画面を出す。
  2. 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
  3. 下記ボックス内をコピーし、標準モジュールに貼り付ける。
  4. モジュール名を【C00_MakeHolidaySht】に変更する。
　モジュール名：C00_MakeHolidaySht
Option Explicit

'+++*********************************************************+++
' 【国民の祝日】シートを作成
'+++*********************************************************+++
Sub MakeHoliSht()

    Dim i As Long
    Dim x As Long
    Dim myY As String
    Dim no As Long
    
    Dim MaxRow As Long        '最終行
    Dim MaxCol As Long        '最終列
    Dim myFtn1 As String
    Dim myFtn2 As String
    Dim myFtn3 As String
    Dim wbName As String
    Dim mySht As Worksheet
    Dim IsBlank As Boolean
    Dim nmlTmn As Boolean               '正常終了フラグ：normal Termination
    
    Const shtName As String = "国民の祝日"
    Const tblName As String = "祝日カレンダー"

    nmlTmn = False
    myProcd = "MakeHoliSht"
    On Error GoTo MakeHoliSht_Err
    Call showStatus("【国民の祝日】シート 作成中")
    Call StopUpdating

    IsCall = False     '初期値
'******************************************************************************
    IsBlank = False
    wbName = ThisWorkbook.Name
    If IsShtOwb(shtName, wbName) = False Then
        With Worksheets(1)
            With .UsedRange
                MaxRow = .Rows(.Rows.Count).Row
                MaxCol = .Columns(.Columns.Count).Column
            End With
        End With
        If MaxRow = 1 And MaxCol = 1 Then
            IsBlank = True
        End If
        If IsBlank Then
            Worksheets(1).Name = shtName
        Else
            ActiveWorkbook.Worksheets.Add Before:=Worksheets(1)
            ActiveSheet.Name = shtName
        End If
    Else
        With ActiveWorkbook.Worksheets(shtName)
            .Select
            .Cells.Clear
        End With
        '一時的にエラー無視
        On Error Resume Next
        Call delShapes
        'エラーハンドリング解除
        On Error GoTo 0
    End If
    Set mySht = ThisWorkbook.Worksheets(shtName)
    
    '【国民の祝日】シートについて
    With mySht
        .Cells(1, 2) = tblName
        .Cells(1, 2).Font.Bold = True
        .Cells(1, 2).Font.Color = 2116941
        .Cells(3, 1) = Year(Date)
        .Cells(3, 2) = "年月日"
        .Cells(3, 3) = "曜日"
        .Cells(3, 4) = "何の日"
        .Cells(4, 1) = 1

        no = 3
        For x = 0 To 2
            myY = Year(Date) + x

            myFtn2 = "=IF(B4<>0,WEEKDAY(B4),"""")"
            myFtn3 = "=IFERROR(WEBSERVICE(""http://api.excelapi.org/datetime/holiday?date=""&$B4),"""")&"""""
            For i = 1 To 22
                no = no + 1
                myFtn1 = "=WEBSERVICE(""http://api.excelapi.org/datetime/holiday-list?year=""&$A$3+" & x & "&""&line=""&$A" & no & ")"

                .Cells(no, 1) = i
                .Cells(no, 2).Formula2 = myFtn1
                If .Cells(no, 2).Value = 0 Then
                    .Cells(no, 2).Value = ""
                End If
            Next i
            
        Next x

        .ListObjects.Add xlSrcRange, Range("A3").CurrentRegion, , xlYes
        With .ListObjects(1)
            .Name = tblName
            .TableStyle = "TableStyleMedium5"
            .Range.HorizontalAlignment = xlCenter
            .ListColumns("年月日").DataBodyRange.HorizontalAlignment = xlLeft
            .ListColumns("年月日").DataBodyRange.InsertIndent 1
            .ListColumns("曜日").DataBodyRange.NumberFormatLocal = "aaaa"
            .ListColumns("曜日").DataBodyRange.HorizontalAlignment = xlLeft
            .ListColumns("曜日").DataBodyRange.InsertIndent 1
            .ListColumns("何の日").DataBodyRange.HorizontalAlignment = xlLeft
            .ListColumns("何の日").DataBodyRange.InsertIndent 1
            .Range.AutoFilter Field:=2, Criteria1:="<>0"
        End With
        .Cells(4, 3).Formula2 = myFtn2
        .Cells(4, 4).Formula2 = myFtn3
        .Calculate
        .Columns("A:D").EntireColumn.AutoFit
        With .ListObjects(1)
            .Range.AutoFilter Field:=2, Criteria1:="<>"
        End With
    End With
MakeHoliSht_Exit:

    '一時的にエラー無視
    On Error Resume Next
    Call Updating

    If nmlTmn Then
        MsgBox " 完了♪"
    End If
    'エラーハンドリング解除
    On Error GoTo 0
Exit Sub

MakeHoliSht_Err:

    MsgBox "実行時エラー:" & Err.Number & "" & _
        Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, myProcd
    Err.Clear          'エラー情報クリア
    GoTo MakeHoliSht_Exit
End Sub

'+++*********************************************************+++
' 【国民の祝日】シートを更新
'+++*********************************************************+++
Sub UpdateHoliSht()

    Dim i As Long
    Dim x As Long
    Dim myY As String
    Dim no As Long
    
    Dim MaxRow As Long        '最終行
    Dim MaxCol As Long        '最終列
    Dim myFtn1 As String
    Dim myFtn2 As String
    Dim myFtn3 As String
    Dim wbName As String
    Dim mySht As Worksheet
    Dim IsBlank As Boolean
    Dim nmlTmn As Boolean               '正常終了フラグ：normal Termination
    
    Const shtName As String = "国民の祝日"
    Const tblName As String = "祝日カレンダー"

    nmlTmn = False
    myProcd = "UpdateHoliSht"
    On Error GoTo UpdateHoliSht_Err
    Call showStatus("【国民の祝日】シート 更新中")
    Call StopUpdating

    IsCall = False     '初期値
'******************************************************************************
    IsBlank = False
    wbName = ThisWorkbook.Name
    If IsShtOwb(shtName, wbName) = False Then
        With Worksheets(1)
            With .UsedRange
                MaxRow = .Rows(.Rows.Count).Row
                MaxCol = .Columns(.Columns.Count).Column
            End With
        End With
        If MaxRow = 1 And MaxCol = 1 Then
            IsBlank = True
        End If
        If IsBlank Then
            Worksheets(1).Name = shtName
        Else
            ActiveWorkbook.Worksheets.Add Before:=Worksheets(1)
            ActiveSheet.Name = shtName
        End If
    Else
        With ActiveWorkbook.Worksheets(shtName)
            .Select
            .Cells.Clear
        End With
        
        '一時的にエラー無視
        On Error Resume Next
        Call delShapes
        'エラーハンドリング解除
        On Error GoTo 0
        
    End If
    Set mySht = ThisWorkbook.Worksheets(shtName)
    
    '【国民の祝日】シートについて
    With mySht
        .Cells(1, 2) = tblName
        .Cells(1, 2).Font.Bold = True
        .Cells(1, 2).Font.Color = 2116941
        .Cells(3, 1) = Year(Date)
        .Cells(3, 2) = "年月日"
        .Cells(3, 3) = "曜日"
        .Cells(3, 4) = "何の日"
        .Cells(4, 1) = 1
        
        .ListObjects.Add xlSrcRange, Range("A3").CurrentRegion, , xlYes
        With .ListObjects(1)
            .Name = tblName
            .TableStyle = "TableStyleMedium5"
            .Range.HorizontalAlignment = xlCenter
            .ListColumns("年月日").DataBodyRange.HorizontalAlignment = xlLeft
            .ListColumns("年月日").DataBodyRange.InsertIndent 1
            .ListColumns("曜日").DataBodyRange.NumberFormatLocal = "aaaa"
            .ListColumns("曜日").DataBodyRange.HorizontalAlignment = xlLeft
            .ListColumns("曜日").DataBodyRange.InsertIndent 1
            .ListColumns("何の日").DataBodyRange.HorizontalAlignment = xlLeft
            .ListColumns("何の日").DataBodyRange.InsertIndent 1
            .Range.AutoFilter Field:=2, Criteria1:="<>0"
        End With

        no = 3
        For x = 0 To 2
            myY = Year(Date) + x

            myFtn2 = "=IF(B4<>0,WEEKDAY(B4),"""")"
            myFtn3 = "=IFERROR(WEBSERVICE(""http://api.excelapi.org/datetime/holiday?date=""&$B4),"""")&"""""
            For i = 1 To 22
                no = no + 1
                myFtn1 = "=WEBSERVICE(""http://api.excelapi.org/datetime/holiday-list?year=""&$A$3+" & x & "&""&line=""&$A" & no & ")"

                .Cells(no, 1) = i
                .Cells(no, 2).Formula2 = myFtn1
                If .Cells(no, 2).Value = 0 Then
                    .Cells(no, 2).Value = ""
                End If
            Next i
            
        Next x

        .Cells(4, 3).Formula2 = myFtn2
        .Cells(4, 4).Formula2 = myFtn3
        .Calculate
        .Columns("A:D").EntireColumn.AutoFit
        Call Updating
        .Calculate
        With .ListObjects(1)
            .DataBodyRange.Value = .DataBodyRange.Value
            .Range.AutoFilter Field:=2, Criteria1:="<>"
            
        End With
        .Range("A3:D3").Interior.Color = 4298904
    End With
    
    ThisWorkbook.Save
    nmlTmn = True
UpdateHoliSht_Exit:

    '一時的にエラー無視
    On Error Resume Next
    Call Updating

    If nmlTmn Then
        MsgBox " 完了♪"
    End If
    'エラーハンドリング解除
    On Error GoTo 0
Exit Sub

UpdateHoliSht_Err:

    MsgBox "実行時エラー:" & Err.Number & "" & _
        Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, myProcd
    Err.Clear          'エラー情報クリア
    GoTo UpdateHoliSht_Exit
End Sub

コメント

タイトルとURLをコピーしました