当日株価データ取得用ユーザー定義関数

当日株価データ更新用ユーザー定義関数を作ってみました。ひょっとしたら、それを用いてサイトへの同時アクセスができるのではないかと思ったのですが、残念ながらその思惑は外れてしまいました。

結局、あまり使い道のないものになってしまいましたが、お蔵入りさせるのも何ですので、ソースコードだけでも残しておきます。
以下のコードをエクセルVBEの標準モジュールにコピーし、シート上の証券コードと市場の２つのセルを引数にして、DataUpdate関数を用いれば、株価データを取得できます。

ただし、本ブログの表示上の問題により、"＜"および"＞"は全角表示としていますので、コピー後、それらを半角に修正してください。

なお、証券コードはヤフーファイナンス上のコード、市場は下記ソースのSelect Case文の表示を参照してください。
また、銘柄名は取得いたしませんので、あらかじめシート上に記載しておくか、別途取得するようソースコードを修正してください。

結果の出力は"/"で区切られ、始値/高値/安値/終値/出来高/前日終値/前日比(額)/前日比(率)/単元株数の順に表示されます。
データはまとまって表示されますので、個々のデータを取得する場合は、マクロを用いるなどして別途取り出してください。

以上、簡単ですが今日はこれで失礼いたします。ご不明な点等ありましたら、コメントいただければ、答えられる範囲で回答いたします。


Function DataUpdate(Code As String, Market As String) As String

Dim cellData(11) As Variant, objXml As Object
Dim mktFlag As String, stcCode As String
Dim idxFlag As Integer, erFlag As Integer
Dim xmlText As String, xmlData() As String
Dim tagCount As Integer, i As Integer
Dim iStart As Integer ', stcName As String

Set objXml = CreateObject("MSXML2.XMLHTTP")

Select Case Left(Market, 2)
Case Is = "東証"
mktFlag = "t"
Case Is = "マザ"
mktFlag = "t"
Case Is = "大証"
mktFlag = "o"
Case Is = "名証"
mktFlag = "n"
Case Is = "名古"
mktFlag = "n"
Case Is = "札証"
mktFlag = "s"
Case Is = "札幌"
mktFlag = "s"
Case Is = "福証"
mktFlag = "f"
Case Is = "JA"
mktFlag = "q"
Case Is = "NE"
mktFlag = "q"
Case Is = "ヘラ"
mktFlag = "j"
Case Is = "HC"
mktFlag = "j"
Case Is = "指数"
If Code = 998405 Then mktFlag = "t"
If Code = 998407 Then mktFlag = "o"
If Code = 23337 Then mktFlag = "q"
Case Else
mktFlag = "t"
End Select

stcCode = Code & "." & mktFlag

'cellData(0) = Code
'cellData(1) = Market
'cellData(2) = stcName

erFlag = 0
idxFlag = 0

If Len(stcCode) ＜＞ 6 And Len(stcCode) ＜＞ 9 Then idxFlag = 1

On Error GoTo 再取得

i = 0

objXml.Open "GET", "http://stocks.finance.yahoo.co.jp/stocks/detail/?code=" & stcCode, False
objXml.Send

On Error GoTo 0

If objXml.Statustext = "OK" Then

xmlText = objXml.responsetext

With CreateObject("VBScript.RegExp")
.Pattern = "＞([^＜＞/]+)＜/strong"
.Global = True

tagCount = .Execute(xmlText).Count
ReDim xmlData(tagCount)

iStart = 0

For i = 0 To tagCount - 1

xmlData(i) = .Execute(xmlText).Item(i)
xmlData(i) = WorksheetFunction.Substitute(xmlData(i), "＞", "")
xmlData(i) = WorksheetFunction.Substitute(xmlData(i), "＜/strong", "")

If xmlData(i) = "期間を保存する" Then iStart = i

If iStart ＜＞ 0 And i - iStart ＞ 20 Then Exit For

Next i

End With

cellData(3) = xmlData(iStart + 2)
cellData(4) = xmlData(iStart + 3)
cellData(5) = xmlData(iStart + 4)

If idxFlag = 1 Then
cellData(7) = "---"
cellData(11) = "---"
Else
cellData(7) = xmlData(iStart + 5)
cellData(11) = xmlData(iStart + 20)
If cellData(11) = "---" Then cellData(11) = 1
End If

cellData(8) = xmlData(iStart + 1)

If cellData(3) = "---" Or cellData(8) = "---" Then

erFlag = 1

End If

With CreateObject("VBScript.RegExp")
.Pattern = "＞([^＜＞]+)＜/span"
.Global = True

tagCount = .Execute(xmlText).Count
ReDim xmlData(tagCount)

iStart = 0

For i = 0 To tagCount - 1

xmlData(i) = .Execute(xmlText).Item(i)
xmlData(i) = WorksheetFunction.Substitute(xmlData(i), "＞", "")
xmlData(i) = WorksheetFunction.Substitute(xmlData(i), "＜/span", "")

If xmlData(i) = "年初来高値" Then iStart = i

If iStart ＜＞ 0 And i - iStart ＞ 0 Then Exit For

Next i

End With

If idxFlag = 1 Or xmlData(iStart - 1) = "前日比" Then
cellData(6) = xmlData(iStart - 2)
Else
cellData(6) = xmlData(iStart - 1)
End If

If erFlag = 1 Then
cellData(9) = "---"
cellData(10) = "---"
Else
cellData(9) = WorksheetFunction.Round(cellData(6) - cellData(8), 2)
cellData(10) = WorksheetFunction.Round(cellData(6) / cellData(8) - 1, 4)
End If

DataUpdate = cellData(3) & "/" & cellData(4) _
& "/" & cellData(5) & "/" & cellData(6) _
& "/" & cellData(7) & "/" & cellData(8) _
& "/" & cellData(9) & "/" & cellData(10) _
& "/" & cellData(11)

Else

DataUpdate = "データ取得に失敗しました。"

End If

Set objXml = Nothing

Exit Function

再取得:

Set objXml = Nothing
Set objXml = CreateObject("MSXML2.XMLHTTP")

objXml.Open "GET", "http://stocks.finance.yahoo.co.jp/stocks/detail/?code=" & stcCode, False

i = i + 1

If i ＜ 10 Then Resume

DataUpdate = "データ取得に失敗しました。"

End Function

タグ：エクセル VBA ユーザー定義関数 株価データ データ取得 マクロ ヤフーファイナンス

コメント 2

めちゃめちゃ頑張ってますね。
見習わねば^^;
by 悪魔くん (2009-07-07 20:39) 

悪魔くん、ありがとうございます。

努力や思いと結果とは、必ずしも連動しないことが難しくもあり、また面白くもあります。

by Ｋフロー (2009-07-08 09:07)