■table.yahoo.co.jp 株価時系列データ取得1

ヤフーファイナンス　株価時系列データ　EXCEL　VBA　データ取り込み　 - 教えて！goo
とっちらかって修正を重ねてしまったので...反省して整理版アップorz
#■WebQueryの失敗（その後でも書いてるけどね。一応、複数銘柄対応。

Option Explicit

'# MSXML2.ServerXMLHTTP を使ってhttp://table.yahoo.co.jpから株価時系列
'# データを取得するコードです.
'#
'# Sheet1のA1..A2..下へ4桁の銘柄コードリストを配置後 Sub Try() を実行.
'# いつまでのデータを取得するかInputBoxで入力.Defaultは Date.各銘柄ごと
'# のシートを追加しながらデータ書き出し.Sheet数/Book考慮しMax50.取得日
'# 最過去値は STARTDAY で設定.
'# VBScript.RegExpでページソース文字列を判定しているのでソースが変われ
'# ば修正必要.

Const STARTDAY As Date = #1/1/2008#　　　　　 '最過去取得日 #m/d/yyyy#
Const MX As Long = 50　　　　　　　　　　　　 '取得コードMAX(シート数)
Const CX As Long = 7　　　　　　　　　　　　　'配列の列数(項目数)
Const PTN = ">([^<>¥n]+)<"　　　　　　　　　　'データ抜き出しパターン
Const CK0 = "<small>調整後終値*</small></th>" 'テーブル判断文字
Const CK1 = "<b class=""yjXL"">"　　　　　　　'銘柄名取得用
Const CK2 = "</b><span class=""yjM"">"　　　　'銘柄名取得用
Const FLD = "日付 始値 高値 安値 終値 出来高 調整後終値*" '列項目名
'---------------------------------------------------------------------
Sub Try()
　　Dim toDate As Date　 '取得終了日
　　Dim rng　　As Range
　　Dim tmp　　As String

　　tmp = Application.InputBox("ToDate yyyy/m/d", , _
　　　　　　　　　　　　　　　 Format$(Date, "yyyy/m/d"), Type:=2)
　　If Not IsDate(tmp) Then MsgBox "Exit": Exit Sub
　　toDate = CDate(tmp)
　　If toDate < STARTDAY Then MsgBox "Exit >=" & STARTDAY: Exit Sub
　　With Sheets("Sheet1")
　　　　'コード範囲を取得
　　　　Set rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
　　End With
　　If rng.Count > MX Then
　　　　MsgBox "コード多過ぎ <=" & MX
　　Else
　　　　'引数:コード範囲,終了日
　　　　Call getXML(rng, toDate)
　　End If

　　Set rng = Nothing
End Sub

#久し振りに10,000文字制限に引っ掛かったので 2 へ XD