株価スクレイピング
VBAで株価スクレイピングしようかと思ったんですが、検索すると圧倒的にPythonがヒットするので、どれだけ高速なのか調査も兼ねてPythonの開発環境を整備して、ある程度動作できるところまでやってみました。
ただ、もう面倒くさい。インタープリターベースの言語がなんでこんなに人気があるのか理解できないです。記述もなんというか美しくないんですよね。新たに言語を覚えるならコンパイラベースのC#とかVB#がいいと思うんですが、どうなんでしょうね。もしかして、エクセルは高くて買えないから無料のPythonということなんでしょうか。それなら無償版Visual Studio使えばいいわけで、とにかくこれ以上時間を無駄にするのも意味がないのでVBAでコードを書いてみました。
ヤフーファイナンスは、スクレイピングを禁止しているので株式投資メモ さんをデータソースにしました。
これは本当に適当なテストハーネスです。 stocksテーブルをMySQLで構築しておいて、SELECT instrument_id FROM stocks; みたいな感じでADOでループさせてもいいし、CSVファイルに4000銘柄持っておいてループさせてもいいし、自分のニーズに合わせて記述すればいいでしょう。FileStreamクラスとGetHTMLTextは別記事を参照のこと。
Public Sub foo()
DownloadStock "1801", "2016", "2019"
End Sub
ダウンロードしてCSVファイルに書き出すモジュールです。 ダウンロードした４本値をMySQLに直接書き出してもいいし、ワークシートに書き出してもいいでしょう。
Public Sub DownloadStock(pStockID As String, pYearFrom As String, pYearTo As String)
Dim sURL As String
Dim buff As String
Dim iPos1 As Long
Dim iPos2 As Long
Dim oPrices As prices
Dim sYear As String
'Dim oRec As Dictionary
Dim oStream As Stream
Dim oFile As FileStream
' ---- Open CSV File
Set oFile = New FileStream
oFile.OpenWriteStream pStockID & ".csv"
' ---- ループ： pYearFrom - pYearTo
sYear = pYearFrom
Do While True
sURL = "https://kabuoji3.com/stock/" & pStockID & "/" & sYear & "/"
buff = modUtil.GetHTMLText(sURL)
Set oPrices = New prices
' ---- レコードトップまで読み飛ばす
'Set oRec = New Dictionary
Set oStream = New Stream
oStream.Buffer = buff
Do Until oStream.EOF
buff = oStream.ReadLine()
If InStr(buff, "<th>終値調整") > 0 Then
Exit Do
End If
Loop
' ---- レコードを読み込む
Do Until oStream.EOF
buff = oStream.ReadLine()
If InStr(buff, "<td>") > 0 Then
oPrices.timestamp = parseString(buff, "<td>", "</td>")
oPrices.openPx = parseString(oStream.ReadLine(), "<td>", "</td>")
oPrices.highPx = parseString(oStream.ReadLine(), "<td>", "</td>")
oPrices.lowPx = parseString(oStream.ReadLine(), "<td>", "</td>")
oPrices.closePx = parseString(oStream.ReadLine(), "<td>", "</td>")
oPrices.volume = parseString(oStream.ReadLine(), "<td>", "</td>")
oPrices.fixedPx = parseString(oStream.ReadLine(), "<td>", "</td>")
'oRec.Add pStockID & ":" & oPrices.timestamp, oPrices
With oPrices
oFile.WriteStream .timestamp & "," & .openPx & "," & .highPx & "," _
& .lowPx & "," & .closePx & "," & .volume & "," & .fixedPx
End With
End If
Loop
sYear = sYear + 1
If sYear > pYearTo Then Exit Do
Loop
oFile.CloseStream
Set oFile = Nothing
End Sub
Private Function parseString(pBuff As String, pKey1 As String, pKey2 As String) As String
Dim iPos1 As Long
Dim iPos2 As Long
iPos1 = InStr(pBuff, pKey1)
iPos2 = InStr(pBuff, pKey2)
If iPos1 + iPos2 = 0 Then
parseString = ""
Else
iPos1 = iPos1 + Len(pKey1)
parseString = Mid(pBuff, iPos1, iPos2 - iPos1)
End If
End Function
クラス：prices
Option Explicit
Public timestamp As String
Public openPx As Long
Public highPx As Long
Public lowPx As Long
Public closePx As Long
Public volume As Long
Public fixedPx As Long
クラス：Stream
Option Explicit
Private m_sBlock As String
Private m_iCurrentPos As Long
' ---------------------------------------------
' 文字列ブロックから1行ずつ読む
' ---------------------------------------------
Public Property Let Buffer(ByVal pBuffer As String)
m_sBlock = pBuffer
m_iCurrentPos = 1
End Property
Public Function ReadLine() As String
Dim iPos As Long
Dim buff As String
Dim iLen As Long
iPos = InStr(m_iCurrentPos, m_sBlock, vbLf)
If iPos > 0 Then
buff = Mid(m_sBlock, m_iCurrentPos, iPos - m_iCurrentPos)
m_iCurrentPos = iPos + 1
ReadLine = buff
Exit Function
End If
iLen = Len(m_sBlock)
If m_iCurrentPos <= iLen Then
ReadLine = Mid(m_sBlock, m_iCurrentPos, iLen - m_iCurrentPos + 1)
m_iCurrentPos = iLen
End If
End Function
Public Function EOF() As Boolean
If m_iCurrentPos < Len(m_sBlock) Then
EOF = False
Else
EOF = True
End If
End Function
余談：楽天マーケットスピードIIをデータソースにすることも可能ですが、VBAのSendKeysもScript HostのSendKeysも安定しません。４本値以外にもアナリティクスが取れるので何とか実現したいものです。EnumerateChildWindowsでウィンドウクラスを拾って・・・とも思いましたが、コールバック関数のアドレスなんて最低でもVB6じゃないと無理だし、あきらめました。っていうか、楽天がAPIを公開してくれてもよさそうなんですけどね。
