VBAのresponseTextのエラー

質問

標題の件で、エクセルのマクロでMSXML2を用いて"モーニングスター [ PTS値上がり率株式ランキング]"というサイトの1ページ目のテーブル内のコード、銘柄名、基準比の値を取得したいのですが"write .responseText"で"システムエラー 1072896658 VBA"が発生してしまい、プログラムをどう修正すればいいか分からずに困っております。

【開発環境】
windows10 Home
エクセル2010
Internet Ecplorer11

【備考】
http://q.hatena.ne.jp/1403712526
"ExcelのVBAで、「e-hon」というサイトのhtmlを取得しようとするとエラーが出ます。"の回答にあるHTML = StrConv(http.responseBody, vbUnicode)はできましたが、
HTMLの中身に取得したいテーブルの内容がDebugPrintで含まれていないことを確認し、他の方法でどう対応すればいいか分からずに行き詰っています。

【プログラム】
※以前に質問したhttps://okwave.jp/qa/q9320858.html"エクセルMSXML2で株価取得"の回答とほぼ同じプログラムです
' ' //
Option Explicit

#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

'モーニングスターPTS値上がり率1ページ目URL　http://www.morningstar.co.jp/StockInfo/pts/ranking?kind=0&page=0
'モーニングスターテーブルclass名：sr-tbl
'ＶＢＥにて参照設定(MSXML2.XMLHTTP):Microsoft XML, v3.0、Microsoft HTML Object Library

Sub MORNINGSTAR_PTSneagari()

Dim i1 As Long 'エクセル初期入力行
Dim j1 As Long 'エクセル初期入力列
Dim i2 As Long '処理済レコード数
Dim j2 As Long 'テーブル上のカレント列Index
Dim objXML As New MSXML2.XMLHTTP
Dim htmlDoc As Object
Dim objTable As MSHTML.HTMLTable 'HTMLテーブルオブジェクト
Dim objCell As MSHTML.HTMLTableCell 'HTMLテーブルセルオブジェクト

Application.Cursor = xlWait 'カーソル砂時計

i1 = 3 'シート行開始位置 固定値
j1 = 1 'シート列開始位置 固定値
i2 = 0 '初期化
j2 = 1 '初期化

Set htmlDoc = New MSHTML.HTMLDocument
With objXML
.Open "GET", "http://www.morningstar.co.jp/StockInfo/pts/ranking?kind=0&page=0", False 'URL入力
.send (Null)
htmlDoc.write .responseText
End With

Sleep (10)

' ' tableタグを総当たりにして、クラス名がヒットしたらobjTable に <table class="sr-tbl"> がセットされた状態でループを抜ける
For Each objTable In htmlDoc.getElementsByTagName("table")
If objTable.className = "sr-tbl" Then Exit For
Next

For Each objCell In objTable.getElementsByTagName("td")
j2 = j2 + 1
If j2 = 2 Then
Cells(i1 + i2-1, j1) = objCell.innerText

ElseIf j2 = 3 Then
Cells(i1 + i2-1, j1) = objCell.innerText

ElseIf j2 = 4 Then
Cells(i1 + i2-1, j1) = objCell.innerText

ElseIf j2 = 7 Then
Cells(i1 + i2+1, j1) = objCell.innerText

ElseIf j2 = 8 Then
Cells(i1 + i2+1, j1) = objCell.innerText

ElseIf j2 >= 10 Then
j2 = 0
i2 = i2 + 1

End If
Next

Set objTable = Nothing: Set htmlDoc = Nothing: Set objXML = Nothing '初期化

Application.Cursor = xlDefault 'カーソル矢印

End Sub
' ' //

ご教授お願いいたします。

回答No.1

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

こんにちは。
さしあたり、当該サイトの利用規約については、
そちらでご確認の上、ご検討くださいね。
こちらも納期が迫ってあまり時間取れなくて
本件にもなかなか着手する余裕がなく返答が遅れましたが、
こちらで出来ることとしては、
<table class="sr-tbl">
を
objTable
に格納するところまで、の対策を提示することだけです。
その後の出力の記述がうまくいっていないことにも
気がついてはいますが、ご要望がわかりませんので、
そちらで工夫して仕上げてあげて下さい。
因みに
　If ... Then ... ElseIf ... Then ... End iif
このステートメントが実際に必要かどうかはわかりませんが、
　Select Case ... Case 2 ... Case n ... End Select
のようにそれぞれ分けて書いたり、
分岐はするけど、処理内容が共通するものが多いならば、
　Select Case
　Case 2, 3, 4, 7, 8
　　出力処理
　Case 10
　　インクリメント処理
　End Select
みたいに書くのが良さそうな気はします。

本題、対策の一例としては、以下の４点です。

１）参照設定 =================
before>' ' ■ MSXML2　　Microsoft XML, v3.0
--------------------
after> ' ' ■ WinHTTP　 Microsoft WinHTTP Services, version 5.1
に換える。
==============================

２）HttpRequestの変数宣言=====
before>　Dim objXML As New MSXML2.XMLHTTP
--------------------
after> 　Dim objXML As New WinHttp.WinHttpRequest
==============================

３）変数宣言の追加=============
Dim b　'　shift-jisバイナリを格納 → unicodeテキストに変換
==============================

４）読込方法の変更====================
before>
　　.send (Null)
　　htmlDoc.write .responseText
--------------------
after>
　　.send (Null)
　　b = .responseBody　'　shift-jisバイナリを格納
　　b = StrConv(b, vbUnicode)　'　unicodeテキストに変換
　　htmlDoc.write b
==============================

ちなみに、
ここで初めて私が回答差し上げたQ9320368でも、
"WinHTTP"を使っていますが、
その時のリンク先になっているQ9123746でも、
質問者さんは"XMLHTTP"でというご要望なのに、
私が"WinHTTP"に替えている理由のひとつは、
今回のような事例が他にもある、という含みがあってのことです。

以上、ご参考まで。

お礼

ご回答ありがとうございます。
いただいたご回答による修正でエラーが消えてプログラムが動作するようになりました！
"WinHTTP"でないと取得できないサイトもあるんですね。
アドバイスをいただけなければずっと"XMLHTTP"で試しており、仮に"WinHTTP"で試していたとしても"responseText"で試していた可能性が高いので悩む時間が短縮でき非常に助かりました。
Select Caseの処理もそのような処理コマンドがあることすら知らなかったので、今後検討してみます。
わざわざ時間を割いていただき、本当にありがとうございました。