株価スクレイピング - 人はエクセルの能力の10%も使っていない？

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を公開してくれてもよさそうなんですけどね。