Excelマクロ　内閣府『国民の祝日CSV』自動DL

Private Declare PtrSafe Function URLDownloadToFile Lib “urlmon” Alias “URLDownloadToFileA” (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare PtrSafe Function SHCreateDirectoryEx Lib “shell32” Alias “SHCreateDirectoryExA” (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Long) As Long

Sub 祝日情報取得()
‘内閣府HPより祝日CSVファイルをダウンロード

Dim strPath As String, strFile As String
Dim WSH As Variant
Dim arrData() As Variant
Dim i As Long, k As Long, r As Long, h As Long
Dim WS As Worksheet
Dim buf As String, tmp


Set WS = Worksheets("祝日情報")

'ドキュメントのパスを取得
Set WSH = CreateObject("WScript.Shell")

strPath = WSH.SpecialFolders("MyDocuments")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

Set WSH = Nothing

strPath = strPath & "祝日情報\" 'CSVファイルの保存フォルダ

Call SHCreateDirectoryEx(0&, strPath, 0&)  'フォルダ作成

strFile = "syukujitsu.csv" 'ファイル名

'ダウンロードするファイル URL
Const TARGET_URL As String = "https://www8.cao.go.jp/chosei/shukujitsu/syukujitsu.csv" '★ダウンロードするCSVファイルのURL

'APIを使ってダウンロード
If URLDownloadToFile(0, TARGET_URL, strPath & strFile, 0, 0) = 0 Then


    With WS
        .Activate

        With .Columns("A:B")
            .Clear
            .ShrinkToFit = True
            .HorizontalAlignment = xlCenter
        End With

        .Range("A1").Value = "日付"
        .Range("B1").Value = "祝日名称"

        .Range("D4").Value = "更新日時：" & Now

        h = 1
        i = 0
        Open strPath & strFile For Input As #1
            Do Until EOF(1)
                Line Input #1, buf

                buf = Replace(buf, """", "")
                tmp = Split(buf, ",")

                If i >= h Then

                    r = .Cells(Rows.Count, 1).End(xlUp).Row + 1

                    .Cells(r, "A").Value = tmp(0)
                    .Cells(r, "B").Value = tmp(1)

                End If
                i = i + 1
            Loop
        Close #1


        '並び替え
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range(.Cells(2, 1), .Cells(r, 1)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

        With WS.Sort
            .SetRange WS.Range(WS.Cells(1, 1), WS.Cells(r, 2))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With


        '罫線
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(1, "A"), .Cells(r, "B")).Borders.LineStyle = True

        ActiveWindow.DisplayGridlines = False

    End With

Else

    MsgBox "祝日情報を更新できません", vbCritical, "処理中断"

End If

End Sub