新生活を充実させるための「こだわり」を取材!!

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

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

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

よろしくお願いします。

教えて!goo グレード

A 回答 (4件)

>(私は、今回そこまでやるつもりはないですが)


...と書いておきながらやるワタシって...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
'---------------------------------------------------------------------
    • good
    • 1

>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
    • good
    • 0
この回答へのお礼

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

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

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

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


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

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

お礼日時:2009/09/12 22:57

致命的ミス発見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
    • good
    • 0

>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]の環境で動作確認してますが、
上手くいかなかったらごめんなさい。
    • good
    • 2

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

教えて!goo グレード

人気Q&Aランキング