為替の時系列データの取り込み(データ更新)

記事「為替の時系列データの取り込み」で
日ごとの為替データ(USD/JPY,EUR/JPY,AUD/JPY)を取得しました。

今回は上記記事で作成したクエリを更新して
最新データを取得していきます。

本記事のマクロを実行する前に
記事「為替の時系列データの取り込み」の内容を
上から順に実行しておいてください。

今回のコードの内容は基本的には
上記記事と同じです。

異なる点を説明します。
前回は最新から一番古いデータまでを
クエリを更新しながら順番に取得していきました。

今回は最新から保存されている一番新しい日付の前までの
データを取得します。
そのために
保存されている一番新しい日付を変数l_dateに格納します。

クエリを更新して
クエリのデータの日付と変数l_dateを比較して
l_dateより大きい日付のデータのみ
各通貨のシートにコピーしていきます。

コピーする際に
前回はデータを一番下にコピーしましたが
今回はデータの一番上の4行目に挿入します。

次のコードは
「通貨ペア」のシートに入力された通貨ペアの
時系列データを更新します。
マクロmacro20200511bの方を実行してください。

Sub macro20200511b()
'「通貨ペア」のシートに入力された通貨ペアの
'為替時系列データ取り込み(更新)

    Dim i As Integer
    Dim end_row As Integer
    Dim cur_str As String
    Dim sh As Object
   
    Set sh = Sheets("通貨ペア")
    end_row = sh.Cells(1, 1).End(xlDown).Row
   
    For i = 2 To end_row
        cur_str = sh.Cells(i, 1)
        Call macro20200511a(cur_str)
    Next i

End Sub
Sub macro20200511a(cur_str As String)
'為替時系列データ取り込み(更新)

    Dim i As Integer, j As Integer
    Dim end_row As Integer
    Dim end_row_q As Integer
    Dim cur_url1 As String, cur_url2 As String
    Dim sh1 As Object
    Dim rng_c As Range, rng_p As Range
    Dim de
    Dim l_date As Date
   
    Set sh1 = Sheets(cur_str)
    l_date = sh1.Cells(4, 1)
   
    cur_url1 = "https://info.finance.yahoo.co.jp/history/?code="
    cur_url2 = "%3DX&sy=1983&sm=1&sd=1&ey=" & Year(Date) & _
        "&em=" & Month(Date) & _
        "&ed=" & Day(Date) & "&tm=d"
   
    For i = 1 To 700
        Debug.Print i & "ページ目取り込み中"
       
        'Webクエリを更新
        With Sheets("為替クエリ").QueryTables("為替")
            .Connection = "URL;" & cur_url1 & cur_str & cur_url2 & "&p=" & i
           
            .BackgroundQuery = False
            .Refresh
        End With
       
        'Webクエリ更新の終了判断
        If Sheets("為替クエリ").Cells(4, 1) = "" Then
            Exit For
        End If
       
        'データをコピー
        end_row_q = 0
        For j = 4 To 23
            If IsDate(Sheets("為替クエリ").Cells(j, 1)) Then
                If Sheets("為替クエリ").Cells(j, 1) > l_date Then
                    end_row_q = j
                Else
                    Exit For
                End If
            Else
                Exit For
            End If
        Next j
       
        If end_row_q = 0 Then
            Debug.Print cur_str & ":最新データに更新完了"
            Exit Sub
        End If
       
        Set rng_c = Sheets("為替クエリ").Range("A4:E" & end_row_q)
        Set rng_p = sh1.Range(sh1.Cells(4, 1), sh1.Cells(end_row_q, 4))
       
        rng_c.Copy
        rng_p.Insert (xlShiftDown)
        sh1.Cells.EntireColumn.AutoFit
       
        'Escキーで中断できるようにDoEventsを挟む
        If i Mod 5 = 0 Then
            de = DoEvents
        End If

    Next i
   
End Sub

実行結果：

前回は2020年5月5日まで取得していたので
赤枠内の5月6日から8日までのデータが追加で取得できました。

使用Ver：Win10, Excel For Office365