Excel Macro Source Code : ネット上のExcelファイルをPCにダウンロードする

東大阪市でコロナ陽性者が急増

MicrosoftのExcelで動作するMacroを作成しましたので公開します。

大阪府庁では、新型コロナウイルス感染症患者の発生状況を公表しており、エクセルのファイルをダウンロードできるようにしてはありますが、2020年11月以降、毎日、ファイルがアップロードされているため、100個以上のファイルがあります。

このような大量のファイルを手動でダウンロードすることは手間がかかります。

このため、一度に大量のファイルをダウンロードできるMacroを作成しました。

下の図は、ダウンロードしたファイルのデータを元に作成しました。

東大阪市でコロナ陽性者が急増していることがわかります。

以下　使い方

任意のフォルダーを新規に作成する。
そのフォルダーに、空のExcelファイルを作成する。
この空のExcelファイルで以降の操作をする。
Excel > 表示 > マクロ > マクロの表示
マクロ名に適当な名前、例えば、aaaと記入し「作成」する。
「Sub aaa() End Sub」を削除する。
下にあるMacroをコピーし、Excel(Microsoft Visual Basic for Applications)に貼り付ける。
Excelで、 > 表示 > マクロ > マクロの表示 > 実行

以上　使い方

動作内容

下のマクロは12月から４月までの対応です。それ以外の月への対応は、Macroを修正する必要があります。
直近のデータファイルには対応していません。直近の１日過去のデータからの取得になります。直近のデータファイルは手動で入手してください。
大阪府庁のファイルの名称には、公表した日付が使われています。本Macroでは、その１日過去の日付の名前で作成します。

' *** 以下 Microsoft Visual Basic for Applications Macro ***

Option Explicit '変数の宣言が必須

Const sURLPre As String = "http://www.pref.osaka.lg.jp/attach/23711/"

Const sURLExtention As String = ".xlsx"

Const sURL202012 As String = "00382605/" '2020年12月分

Const sURL202101 As String = "00385104/" '2021年１月分

Const sURL202102 As String = "00386452/" '2021年２月分

Const sURL202103 As String = "00391351/" '2021年３月分

Const sURL202104 As String = "00376069/" '2021年４月分

Const iNumberOfMonth = 5 '月分の個数

Const dStart As Date = "12/1/2020" '開始の年月日 2020年12月分

Const iErrorTimes As Integer = 6

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

Sub No1_DownLoadExcelFile_Osaka()

'download data from below url

'http://www.pref.osaka.lg.jp/iryo/osakakansensho/happyo.html

'url sample string is below

'http://www.pref.osaka.lg.jp/attach/23711/00386452/0228.xlsx

'大阪府庁のExcelのファイル名は、公表をした日付である。

'データ内容は、その前日分である。

'このため、本Macroで作成するExcelファイルの名前は、前日の日付にしてある。

Dim iMonth As Integer

Dim sArrayURLMonth(iNumberOfMonth)

Dim d As Date

Dim iThisMonth As Integer, iNextMonth As Integer, iFiles As Integer

Debug.Print vbCrLf

Debug.Print "*** Macro newly began! *** " + Format(Now, "yyyy/mm/dd HH:mm:ss")

iFiles = 0

sArrayURLMonth(0) = sURL202012

sArrayURLMonth(1) = sURL202101

sArrayURLMonth(2) = sURL202102

sArrayURLMonth(3) = sURL202103

sArrayURLMonth(4) = sURL202104

d = dStart

For iMonth = 0 To iNumberOfMonth - 1

Dim sURLMonth As String, sURL As String

Dim sOutputPath As String

sURLMonth = sURLPre + sArrayURLMonth(iMonth)

iThisMonth = Month(d)

iNextMonth = iThisMonth

Do While iThisMonth = iNextMonth

'前日の日付でファイル名を作成する

sOutputPath = ThisWorkbook.Path & "/" & Format(d - 1, "yyyymmdd") & ".xlsx"

If Dir(sOutputPath) = "" Then 'if no file

Dim lgRet As Long

Dim sError As String

Dim iErrors As Integer

iErrors = 0

lgRet = -1

Do While lgRet <> 0 And iErrors < iErrorTimes

Select Case iErrors

Case 0

sURL = sURLMonth + Format(d, "mmdd") + sURLExtention

Case 1

sError = " "

sURL = sURLMonth + Format(d, "mmdd") + sError + sURLExtention

Case 2

sError = "_2"

sURL = sURLMonth + Format(d, "mmdd") + sError + sURLExtention

Case 3

sError = "-2"

sURL = sURLMonth + Format(d, "mmdd") + sError + sURLExtention

Case 4

sError = "_2 "

sURL = sURLMonth + Format(d, "mmdd") + sError + sURLExtention

Case 5

sError = "syusei"

sURL = sURLMonth + sError + Format(d, "mmdd") + sURLExtention

End Select

lgRet = URLDownloadToFile(0, sURL, sOutputPath, 0, 0)

iErrors = iErrors + 1

Loop

If lgRet = 0 Then

iFiles = iFiles + 1

Else

Debug.Print "failed : " + Format(d, "yyyymmdd")

End If

d = DateAdd("d", 1, d) '１日加算する

iNextMonth = Month(d)

If d >= Date Then '今日の日付以降は処理しない

iMonth = iNumberOfMonth

Exit Do

End If

Loop

Next iMonth

Debug.Print "Number of created excel files is " + str(iFiles)

Debug.Print "*** Macro ended! *** " + Format(Now, "yyyy/mm/dd HH:mm:ss")

End Sub

' *** 以上 Microsoft Visual Basic for Applications Macro ***