ヤフーファイナンス 株価時系列データ EXCEL VBA データ取り込み

質問

ヤフーファイナンスの株価時系列データを、EXCELのVBAを使って、1回のマクロ操作で複数銘柄EXCELに取り込みたいと考えています。

EXCEL　Sheet1のA1、A2、A3、、、に取り込みたい銘柄コードを記入し、マクロを走らせると同ブック内で銘柄コード別にシートが出来上がるのが理想です。

データ取得期間は”デイリー”で”1999/1/1～2012/1/1”を考えています。

よろしくお願いします。

回答No.2

end-u · ベストアンサー

>（私は、今回そこまでやるつもりはないですが）
...と書いておきながらやるワタシって...orz

Option Explicit
Sub test()
　　Dim fromDate As Date '取得開始日
　　Dim toDate　 As Date '取得終了日
　　Dim n　　　　As Long
　　Dim d, cds()

　　'Dim t As Single
　　't = Timer
　　'toDateに取得終了日をセット可能
　　toDate = Date '#8/31/2009#
　　With Sheets("Sheet1")
　　　　'B1セルから前回取得終了日をセット。最初は未入力で可
　　　　d = .Range("B1").Value
　　　　If IsDate(d) Then
　　　　　　If d >= toDate Then Exit Sub
　　　　　　fromDate = CDate(d + 1)
　　　　End If
　　　　'B1未入力だったら1999.1.1
　　　　If fromDate < #1/1/1999# Then
　　　　　　fromDate = #1/1/1999#
　　　　End If
　　　　'銘柄コードを配列で取得
　　　　n = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　If n = 1 Then
　　　　　　ReDim cds(0)
　　　　　　cds(0) = .Range("A1").Value
　　　　Else
　　　　　　cds() = .Range("A1").Resize(n).Value
　　　　End If
　　　　'引数:銘柄配列, 開始日, 終了日
　　　　Call getXML(cds(), fromDate, toDate)
　　　　'B1セルに今回取得終了日
　　　　.Range("B1").Value = toDate
　　End With
　　'Debug.Print Timer - t
End Sub
'---------------------------------------------------------------------
Sub getXML(ByRef cds() As Variant, _
　　　　　 ByVal dCHK As Date, _
　　　　　 ByVal dDate As Date)
　　Const FLD = "日付 始値 高値 安値 終値 出来高 調整後終値*" '列項目名
　　Const CX As Long = 7　　　　　　　　　　　　　　　　　　　'配列の列数（項目数）
　　Const PTN = ">([^<>\n]+)<"　　　　　　　　　　　　　　　　'データ抜き出しパターン
　　Const CHK = "<small>調整後終値*</small></th>"　　　　　　 'テーブル判断項目htmlTEXT
　　Dim dTMP As Date　　　'検索開始Date
　　Dim xh　 As Object　　'MSXML2.ServerXMLHTTP
　　Dim re　 As Object　　'VBScript.RegExp
　　Dim mc　 As Object　　'RegExp.Match
　　Dim ws　 As Worksheet 'データ書き出しSheet
　　Dim flg　As Boolean　 'LoopOut判定FLG
　　Dim url　As String　　'URLアドレス
　　Dim ret　As String　　'XMLHTTP.responsetext
　　Dim s(7) As String　　'URL構成文字列
　　Dim dX　 As Long　　　'期間日数
　　Dim n　　As Long　　　'chk文字存在判定
　　Dim x　　As Long　　　'HTML項目Loop用
　　Dim cnt　As Long　　　'データCOUNT
　　Dim i　　As Long
　　Dim j　　As Long
　　Dim k　　As Long
　　Dim v, w　　　　　　　'データ格納用配列,列項目名分割用配列
　　Dim cd　　　　　　　　'銘柄Loop用

　　On Error Resume Next
　　Set xh = CreateObject("MSXML2.ServerXMLHTTP")
　　On Error GoTo 0
　　If xh Is Nothing Then Exit Sub

　　On Error GoTo errHndlr

　　'開始日より1ページ多目に
　　dTMP = DateAdd("d", -50, dCHK)
　　s(1) = "c=" & Year(dTMP)　'開始年
　　s(2) = "a=" & Month(dTMP)　　'開始月
　　s(3) = "b=" & Day(dTMP)　 '開始日
　　s(4) = "f=" & Year(dDate)　'現在年
　　s(5) = "d=" & Month(dDate)　　'現在月
　　s(6) = "e=" & Day(dDate)　 '現在日
　　s(7) = "g=d&q=t&y="

　　dX = CLng(dDate - dCHK) + 1
　　'期間日数から配列の大きさを設定（+1がちょっと肝）
　　ReDim v(1 To dX + 1, 1 To CX)
　　w = Split(FLD)

　　Set re = CreateObject("VBScript.RegExp")
　　re.Pattern = PTN
　　re.Global = True

　　'コード範囲をLoop
　　For Each cd In cds
　　　　s(0) = "http://table.yahoo.co.jp/t?s=" & cd
　　　　url = Join(s, "&")
　　　　cnt = 1
　　　　For i = 0 To dX Step 50
　　　　　　xh.Open "GET", url & i, False
　　　　　　xh.Send
　　　　　　If (xh.Status >= 200) And (xh.Status < 300) Then
　　　　　　　　ret = xh.responsetext
　　　　　　　　n = InStr(ret, CHK)
　　　　　　　　If n = 0 Then Exit For
　　　　　　　　ret = Mid$(ret, n + Len(CHK))
　　　　　　　　Set mc = re.Execute(ret)
　　　　　　　　x = 0
　　　　　　　　For j = 1 + i To 50 + i
　　　　　　　　　　cnt = j
　　　　　　　　　　For k = 1 To CX
　　　　　　　　　　　　v(j, k) = mc(x).submatches(0)
　　　　　　　　　　　　'データ終了判定
　　　　　　　　　　　　If k = 1 Then
　　　　　　　　　　　　　　flg = IsDate(v(j, 1))
　　　　　　　　　　　　　　If flg Then
　　　　　　　　　　　　　　　　v(j, 1) = CDate(v(j, 1))
　　　　　　　　　　　　　　　　flg = (v(j, 1) >= dCHK)
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　If Not flg Then
　　　　　　　　　　　　　　　　j = i + 50
　　　　　　　　　　　　　　　　i = dX
　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　　　x = x + 1
　　　　　　　　　　Next
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　　　On Error GoTo shtAdd
　　　　Set ws = Sheets(CStr(cd))
　　　　On Error GoTo errHndlr
　　　　With ws
　　　　　　'データ書き出し
　　　　　　.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
　　　　　　.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
　　　　　　　　　　　　　　　　　　　　　　Order1:=xlDescending, _
　　　　　　　　　　　　　　　　　　　　　　Header:=xlYes, _
　　　　　　　　　　　　　　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　　　　　　　　　　　　　　MatchCase:=True, _
　　　　　　　　　　　　　　　　　　　　　　Orientation:=xlSortColumns, _
　　　　　　　　　　　　　　　　　　　　　　SortMethod:=xlStroke
　　　　End With
　　Next

errHndlr:
　　Set mc = Nothing
　　Set re = Nothing
　　Set xh = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　MsgBox .Number & vbLf & .Description
　　　　End If
　　End With
　　Exit Sub

shtAdd:
　　'新規コード時Sheet追加
　　With Sheets.Add
　　　　.Name = CStr(cd)
　　　　.Columns(1).NumberFormat = "yyyy/mm/dd"
　　　　.Range("A1").Resize(, CX).Value = w
　　End With
　　Resume
End Sub
'---------------------------------------------------------------------

回答No.4

end-u

>With ws
>　　'データ書き出し
>　　.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
>　　.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
>　　　　　　　　　　　　　　　　　　Order1:=xlDescending, _
>　　　　　　　　　　　　　　　　　　Header:=xlYes, _
>　　　　　　　　　　　　　　　　　　OrderCustom:=1, _
>　　　　　　　　　　　　　　　　　　MatchCase:=True, _
>　　　　　　　　　　　　　　　　　　Orientation:=xlSortColumns, _
>　　　　　　　　　　　　　　　　　　SortMethod:=xlStroke
>End With
この後に

Set ws = Nothing

入れてください。
#やっぱ修行が足りんです XD

お礼

ご回答ありがとうございます。

早速マクロ走らせてみました。

素晴らしい、バッチリです！！

追加仕様まで付けていただきとても感謝しています。

取り込み頻度が毎日なので、非常に助かりますm(__)m

本当にありがとうございます。

回答No.3

end-u

致命的ミス発見orz

>　　　　On Error GoTo shtAdd
>　　　　Set ws = Sheets(CStr(cd))
>　　　　On Error GoTo errHndlr
>　　　　With ws
>　　　　　　'データ書き出し
>　　　　　　.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
>　　　　　　.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
>　　　　　　　　　　　　　　　　　　　　　　Order1:=xlDescending, _
>　　　　　　　　　　　　　　　　　　　　　　Header:=xlYes, _
>　　　　　　　　　　　　　　　　　　　　　　OrderCustom:=1, _
>　　　　　　　　　　　　　　　　　　　　　　MatchCase:=True, _
>　　　　　　　　　　　　　　　　　　　　　　Orientation:=xlSortColumns, _
>　　　　　　　　　　　　　　　　　　　　　　SortMethod:=xlStroke
>　　　　End With
>　　Next
>
>errHndlr:
>　　Set mc = Nothing
>　　Set re = Nothing
>　　Set xh = Nothing
>　　With Err()
>　　　　If .Number <> 0 Then
>　　　　　　MsgBox .Number & vbLf & .Description
>　　　　End If
>　　End With
>　　Exit Sub
>
>shtAdd:
>　　'新規コード時Sheet追加
>　　With Sheets.Add
>　　　　.Name = CStr(cd)
>　　　　.Columns(1).NumberFormat = "yyyy/mm/dd"
>　　　　.Range("A1").Resize(, CX).Value = w
>　　End With
>　　Resume
>End Sub

差し替えです。

　　　　If cnt > 1 Then
　　　　　　On Error Resume Next
　　　　　　Set ws = Sheets(CStr(cd))
　　　　　　'新規コード時Sheet追加
　　　　　　If ws Is Nothing Then
　　　　　　　　Set ws = Sheets.Add
　　　　　　　　ws.Name = CStr(cd)
　　　　　　　　ws.Columns(1).NumberFormat = "yyyy/mm/dd"
　　　　　　　　ws.Range("A1").Resize(, CX).Value = w
　　　　　　End If
　　　　　　On Error GoTo errHndlr
　　　　　　With ws
　　　　　　　　'データ書き出し
　　　　　　　　.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
　　　　　　　　.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
　　　　　　　　　　　　　　　　　　　　　　　　Order1:=xlDescending, _
　　　　　　　　　　　　　　　　　　　　　　　　Header:=xlYes, _
　　　　　　　　　　　　　　　　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　　　　　　　　　　　　　　　　MatchCase:=True, _
　　　　　　　　　　　　　　　　　　　　　　　　Orientation:=xlSortColumns, _
　　　　　　　　　　　　　　　　　　　　　　　　SortMethod:=xlStroke
　　　　　　End With
　　　　End If
　　Next

errHndlr:
　　Set mc = Nothing
　　Set re = Nothing
　　Set xh = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　MsgBox .Number & vbLf & .Description
　　　　End If
　　End With
End Sub

回答No.1

end-u

>1999/1/1～2012/1/1
これは最新日までのデータを累積していきたいって事ですよね。
追加で取り込む頻度は毎日？毎週？
それによってコードの組み方も随分と変わってきます。
特にIE7の場合、table.yahoo.co.jpではWebクエリ連続実行が使えない場合がありますから
難易度も上がると思いますよ。

とりあえず、昔 /qa4201932.html で書いた事があるのでザッと修正したものを提示しておきます。
1999/1/1～最新日まで取り込みます。
シートを追加してコードをシート名にしますので既存シート名とダブりが無いようにしてください。

内容を理解して応用すれば、ある一定の期間からの追加仕様に変更できるかと思います。
（私は、今回そこまでやるつもりはないですが）

Option Explicit

Sub try()
　　Const FLD As String _
　　　　= "日付 始値 高値 安値 終値 出来高 調整後終値*"　　'列項目名
　　Const CX As Long = 7　　　　　　　　　　　　　　　　　 '配列の列数（項目数）
　　'Const YY As Long = 10　　　　　　　　　　　　　　　　　'期間年数
　　Const PTN As String = ">([^<>\n]+)<"　　　　　　　　　 'データ抜き出しパターン

　　Dim dCHK As Date　　'開始期間Date
　　Dim dTMP As Date　　'検索開始Date
　　Dim xh　 As Object　'MSXML2.ServerXMLHTTP
　　Dim re　 As Object　'VBScript.RegExp
　　Dim mc　 As Object　'RegExp.Match
　　Dim url　As String　'URLアドレス
　　Dim chk　As String　'テーブル判断項目htmlTEXT
　　Dim ret　As String　'XMLHTTP.responsetext
　　Dim s(7) As String　'URL構成文字列
　　Dim flg　As Boolean 'LoopOut判定FLG
　　Dim rng　As Range　 '銘柄コード範囲
　　Dim r　　As Range　 'RangeLoop用
　　Dim dX　 As Long　　'期間日数
　　Dim n　　As Long　　'chk文字存在判定
　　Dim x　　As Long　　'HTML項目Loop用
　　Dim cnt　As Long　　'データCOUNT
　　Dim i　　As Long
　　Dim j　　As Long
　　Dim k　　As Long
　　Dim v, w　　　　　　'データ格納用配列,列項目名分割用配列
　　'Dim t As Single

　　On Error Resume Next
　　Set xh = CreateObject("MSXML2.ServerXMLHTTP")
　　On Error GoTo 0
　　If xh Is Nothing Then Exit Sub

　　'銘柄コードを記入している範囲を取得
　　With Sheets("Sheet1")
　　　　Set rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
　　End With
　　w = Split(FLD)

　　'#m/d/yyyy#で開始日を設定
　　dCHK = #1/1/1999#　　'DateAdd("yyyy", -YY, Date)
　　'開始日より1ページ多目に
　　dTMP = DateAdd("d", -50, dCHK)
　　s(1) = "c=" & Year(dTMP)　'開始年
　　s(2) = "a=" & Month(dTMP)　　'開始月
　　s(3) = "b=" & Day(dTMP)　 '開始日
　　s(4) = "f=" & Year(Date)　'現在年
　　s(5) = "d=" & Month(Date)　　'現在月
　　s(6) = "e=" & Day(Date)　 '現在日
　　s(7) = "g=d&q=t&y="

　　dX = CLng(Date - dCHK) + 1
　　'期間日数から配列の大きさを設定
　　ReDim v(0 To dX, 1 To CX)
　　'テーブル判断項目htmlTEXT
　　chk = "<small>" & w(CX - 1) & "</small></th>"
　　For i = 1 To CX
　　　　v(0, i) = w(i - 1)
　　Next

　　Set re = CreateObject("VBScript.RegExp")
　　re.Pattern = PTN
　　re.Global = True

　　't = Timer
　　'コード範囲をLoop
　　For Each r In rng
　　　　s(0) = "http://table.yahoo.co.jp/t?s=" & r.Value
　　　　url = Join(s, "&")
　　　　cnt = 1
　　　　For i = 0 To dX Step 50
　　　　　　xh.Open "GET", url & i, False
　　　　　　xh.Send
　　　　　　If (xh.Status >= 200) And (xh.Status < 300) Then
　　　　　　　　ret = xh.responsetext
　　　　　　　　n = InStr(ret, chk)
　　　　　　　　If n = 0 Then Exit For
　　　　　　　　ret = Mid$(ret, n + Len(chk))
　　　　　　　　Set mc = re.Execute(ret)
　　　　　　　　x = 0
　　　　　　　　For j = 1 + i To 50 + i
　　　　　　　　　　cnt = j
　　　　　　　　　　For k = 1 To CX
　　　　　　　　　　　　v(j, k) = mc(x).submatches(0)
　　　　　　　　　　　　'データ終了判定
　　　　　　　　　　　　If k = 1 Then
　　　　　　　　　　　　　　flg = IsDate(v(j, 1))
　　　　　　　　　　　　　　If flg Then
　　　　　　　　　　　　　　　　flg = (CDate(v(j, 1)) >= dCHK)
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　If Not flg Then
　　　　　　　　　　　　　　　　j = i + 50
　　　　　　　　　　　　　　　　i = dX
　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　　　x = x + 1
　　　　　　　　　　Next
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　　　'Debug.Print cnt
　　　　'シート追加し書き出し。
　　　　With Sheets.Add
　　　　　　.Range("A1").Resize(cnt, CX).Value = v
　　　　　　On Error Resume Next
　　　　　　.Name = r.Value
　　　　　　On Error GoTo 0
　　　　End With
　　　　'Debug.Print Timer - t
　　　　't = Timer
　　Next

　　Set rng = Nothing
　　Set mc = Nothing
　　Set re = Nothing
　　Set xh = Nothing
End Sub

一応、[winXPsp3/xl2003sp3][vistasp1/xl2007sp1]の環境で動作確認してますが、
上手くいかなかったらごめんなさい。