CSVファイルをダウンロードしてシートにセットする

はじめに

以前に作成したカレンダーの祝日は、内閣府のホームページからダウンロードして利用するようになっております。

ボタンを押して取り込めれば非常に簡単になるので作ってみました。

ダウンロード

CSVファイルをダウンロード

1 ファイル 27.10 KB

ダウンロード

※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ファイルをシートに貼り付ける処理を行っております。

#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

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で数値に変換しています。

おわりに

カレンダーマクロの祝日シートにボタンを配置することで便利になると思います。その際には元のカレンダーをクリアすることや、ヘッダの設定にも気をつける必要があります。