エクセルでXMLHTTPを用いて株の経常益を取得

質問

エクセルのマクロでXMLHTTPを用いて株の経常益を取得したい

株探の決算表から、ウェブクエリでテーブルをエクセルに取り込むことは出来ました。
しかし100銘柄～200銘柄のテーブルを取り込むと膨大な時間がかかってしまいます。
取り込む時間を最小限にするために、テーブルの中の一か所だけを取り込むようにしたいです。
ウェブクエリだとそれは無理らしいので、XMLHTTPを用いて株の経常益を取得したいです。

例：1301
・ＵＲＬ　http://kabutan.jp/stock/finance?code=1301
・テーブル「今期予想」の「予 2016.03」の「経常益」のみ（3000という数字のみ）を取り込みたい

どうかご教示ください。

回答No.1

real beatin（@realbeatin） · ベストアンサー

こんにちは。こんな感じ？

以下【テスト条件】
●新しいブックの
●Sheet1に
●以下のデータサンプルを作成
　（１行め空行、２行め項目名、A3以下に[コード]）
ーーーーー
　Ａ列　Ｂ列
１｜　-（空行）-
２｜コード　銘柄名
３｜1301　極洋
４｜1333　マ..
５｜1377　サ..
６｜1573　Ｈ..
７｜1853　森..
８｜1878　大..
９｜1959　九..
10｜2001　日..
11｜2032　ハ..
12｜2124　ジ..
13｜2212　山..
14｜2222　寿..
15｜2290　米..
16｜2317　シ..
17｜2337　い..
18｜2393　ケ..
ーーーーー
●ＶＢＥにて２件参照設定
　Microsoft WinHTTP Services, version 5.1
　Microsoft HTML Object Library
●標準モジュールを挿入して、
　〓標準モジュール〓のスクリプトを貼付け
●クラスモジュールを挿入して（名前はClass1のまま）、
　〓Class1（クラス）モジュール〓のスクリプトを貼付け
●スクリプト内の■マークの行にて
　動作条件の指定変更または確認を済ませる
●ブック保存
●実行
　Sub StartWinHttpRequest()
●出力結果は上記Sheet1のサンプル右の空いている列（C列→）

' ' ///

' ' 〓〓〓　標準モジュール　〓〓〓
Option Explicit
Public Const STBL As String = "今期*"　'　■テーブル名？
Public Const SFLD As String = "経常益"　'　■フィールド名？
Private Const SSHT As String = "Sheet1"　'　■シート名？
Private Const TRACKS As Long = 24&　'　■Collectionの基準サイズ？

Public mtxSrc ' 読込用二次元配列
Public mtxPrt ' 出力用〃
Public tnThreads As Long ' Thread 総件数
Public cnSent As Long ' Request/Send済のThread数
Public cnThRest As Long ' 未処理残件数( <> tnThreads - cnSent )
Private colCls As VBA.Collection　'　Class1クラスコレクション

Sub StartWinHttpRequest()
Dim tnCol As Long　'　Collectionの実行時サイズ
Dim i As Long
　Application.Cursor = xlWait
　With Sheets(SSHT)
　　If .FilterMode Then .ShowAllData
　　mtxSrc = .Range("A3:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value　'　■[コード]データ先頭は A3 ？
　End With
　tnThreads = UBound(mtxSrc)
　ReDim mtxPrt(1 To tnThreads, 1 To 2)
　tnCol = TRACKS
　If tnThreads < TRACKS Then tnCol = tnThreads
　cnSent = 0&
　cnThRest = tnThreads
　Set colCls = New Collection
　For i = 1 To tnCol
　　colCls.Add New Class1, CStr(i)
　Next i
End Sub

Private Sub ResPrint()
Dim nColPos As Long
　If colCls Is Nothing Then Exit Sub
　Set colCls = Nothing
　If ActiveSheet.Name <> SSHT Then Sheets(SSHT).Select
　nColPos = Cells(2, Columns.Count).End(xlToLeft).Column + 1　'　■出力位置・内容は適宜
　Cells(1, nColPos).Resize(, 2).Value = Array(STBL, "予想")　'　■　〃
　Cells(2, nColPos).Resize(, 2).Value = Array(SFLD, Date)　'　■　〃
　Cells(3, nColPos).Resize(tnThreads, 2).Value = mtxPrt　'　■　〃
　Erase mtxSrc, mtxPrt
　Application.Cursor = xlDefault
End Sub

' ' 〓〓〓　Class1（クラス）モジュール　〓〓〓
Option Explicit
Private Const URL1 As String = "http://kabutan.jp/stock/finance?code="　'　■
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
Private WithEvents oWinReq As WinHttpRequest
Private oDoc As HTMLDocument
Private nThrdIdx As Long　'　「今このクラスでは何番目を処理しているのか」

Private Sub Class_Initialize()
　Set oWinReq = New WinHttpRequest
　Me.RequestAsync
　Set oDoc = New HTMLDocument
End Sub

Private Sub oWinReq_OnResponseFinished()
Dim oElm As IHTMLElement
Dim oTable As HTMLTable
Dim oCell As HTMLTableCell
Dim oRow As HTMLTableRow
Dim sHTML As String
Dim nFld As Long

On Error GoTo Rep_
　sHTML = oWinReq.responseText
　oDoc.body.innerHTML = sHTML
　Sleep (10)

　Set oElm = oDoc.getElementById("finance_box")

　For Each oTable In oElm.getElementsByTagName("table")
　　If oTable.PreviousSibling.innerText Like STBL Then Exit For
　Next
　Set oElm = Nothing

　For Each oCell In oTable.Rows(0).Cells
　　If oCell.innerText = SFLD Then Exit For
　Next
　nFld = oCell.cellIndex
　Set oCell = Nothing

　For Each oRow In oTable.Rows
　　If Trim$(oRow.Cells(0).innerText) Like "予*" Then Exit For
　Next
Rep_:
　Err.Clear
　If oRow Is Nothing Then
　　mtxPrt(nThrdIdx, 1) = "-"　' ■ 無効なデータだった場合　Empty　？
　　mtxPrt(nThrdIdx, 2) = "-"　' ■　〃
　Else
　　mtxPrt(nThrdIdx, 1) = oRow.Cells(nFld).innerText
　　mtxPrt(nThrdIdx, 2) = Replace$(Right$(Trim$(oRow.Cells(0).innerText), 7), ".", "-")
　End If
　Set oRow = Nothing

' ' ▼未処理スレ数　減算▼
　cnThRest = cnThRest - 1&

　If cnSent < tnThreads Then
　　Me.RequestAsync
　Else
　　oWinReq.abort: Set oWinReq = Nothing: Set oDoc = Nothing
　' ' ▼未処理スレ数 = 0&　ならば▼最終出力処理
　　If cnThRest = 0& Then
　　　Application.OnTime Now, "ResPrint"
　　End If
　End If
End Sub

Sub RequestAsync()
　cnSent = cnSent + 1&
　nThrdIdx = cnSent
　With oWinReq
' '　WinHttp非同期リクエスト
　　.Open Method:="GET", URL:=URL1 & CStr(mtxSrc(nThrdIdx, 1)), Async:=True
　　.Send
　End With
End Sub

' ' ///

お礼

ありがとうございます。
出来ました！

ウェブクエリでも四苦八苦する私にはXMLHTTPはとてつもなくハードルが高かったので、本当に助かりました。