はじめに
以前に作成したカレンダーの祝日は、内閣府のホームページからダウンロードして利用するようになっております。
ボタンを押して取り込めれば非常に簡単になるので作ってみました。
ダウンロード
※ZIP圧縮形式なのでどこかに解凍してご利用ください。
ちょこっと解説
メインシート
ダウンロードするファイルのURIと貼り付け先のシート名＆針付け位置の開始アドレスを指定できます。
処理開始ボタンを押すと「Sheet2」の「A1」からデータを貼り付けます。
Sheet2の初期状態
処理完了後のSheet2
VBA
ファイルのダウンロードは、WindowsAPIを利用します。Excel32bit版と64bit版の両方を定義してあります。
Private Sub cmdCsvSet_Click() は処理開始ボタンを押したときのイベントです。
Private Sub SetCSVtoSheet(fileName As String, sheetName As String, startAddr As String) はダウンロードしたCSVファイルをシートに貼り付ける処理を行っております。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
#If Win64 Then ' 指定URLファイルのダウンロード 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 DeleteUrlCacheEntry _ Lib "wininet" Alias "DeleteUrlCacheEntryA" _ (ByVal lpszUrlName As String) As Long ' スリープ Private Declare PtrSafe Sub Sleep _ Lib "kernel32" (ByVal dwMilliseconds As Long) #Else ' 指定URLファイルのダウンロード Private Declare 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 Function DeleteUrlCacheEntry _ Lib "wininet" Alias "DeleteUrlCacheEntryA" _ (ByVal lpszUrlName As String) As Long ' スリープ Private Declare Sub Sleep _ Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Private Sub cmdCsvSet_Click() Dim fileURL As String Dim fileName As String Dim sheetName As String Dim startAddr As String Dim ret On Error GoTo DownloadErr ' ファイルダウンロード ' ダウンロードファイル fileURL = Sheet1.Cells(4, 2).Value fileName = ThisWorkbook.Path & "\" & "work.csv" ' 貼り付け先シート＆アドレス sheetName = Sheet1.Cells(6, 2).Value startAddr = Sheet1.Cells(7, 2).Value ' キャッシュクリア Call DeleteUrlCacheEntry(fileURL) ' ダウンロード ret = URLDownloadToFile(0, fileURL, fileName, 0, 0) '// 1秒スリープ Call Sleep(1000) ' ダウンロード結果 If ret = 0 Then 'MsgBox "ダウンロード完了" Else GoTo DownloadErr End If ' CSV取り込み Call SetCSVtoSheet(fileName, sheetName, startAddr) MsgBox "完了しました。" Exit Sub DownloadErr: MsgBox "ダウンロード：" & Err.Description End Sub Private Sub SetCSVtoSheet(fileName As String, sheetName As String, startAddr As String) Dim f As Integer Dim i As Integer Dim str(2) As String Dim sRow As Integer Dim sCol As Integer If Dir(fileName) = "" Then MsgBox "ファイルが存在しません" Exit Sub End If ' ファイルオープン f = FreeFile Open fileName For Input As #f On Error GoTo ErrHandler ' 出力開始アドレス sRow = Range(startAddr).Row sCol = Range(startAddr).Column ' データ出力 i = 0 Do While Not EOF(f) Input #f, str(1), str(2) With Sheets(sheetName) .Cells(sRow + i, sCol).Value = str(1) .Cells(sRow + i, sCol + 1).Value = str(2) End With i = i + 1 Loop ' ファイルクローズ Close #f Exit Sub ErrHandler: On Error Resume Next ' ファイルクローズ Close #f MsgBox Err.Description End Sub |
ポイント
貼り付け開始位置は、A1などと指定していますが、Cellsではそのまま利用できませんので、Range("A1").RowとRange("A1").Columnで数値に変換しています。
おわりに
カレンダーマクロの祝日シートにボタンを配置することで便利になると思います。その際には元のカレンダーをクリアすることや、ヘッダの設定にも気をつける必要があります。