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

>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

投稿日時 - 2009-09-10 01:55:02

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

投稿日時 - 2009-09-09 22:06:28

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

投稿日時 - 2009-09-09 00:43:36