VBAのresponseTextのエラー

2023/09/06 22:31

このQ&Aのポイント

VBAのresponseTextでエラーが発生し、プログラムの修正方法がわかりません。
エクセルのマクロでMSXML2を使用して特定のサイトのテーブル内の情報を取得したいが、エラーが発生しています。
質問者は以前に同様の質問をしており、回答では文字コードの変換が行われていましたが、別の方法についても検討したいと思っています。

ベストアンサー

VBAのresponseTextのエラー

2017/04/26 06:03

標題の件で、エクセルのマクロで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 ' ' // ご教授お願いいたします。

shintakane
お礼率100% (4/4)

Excel（エクセル）
回答数1
ありがとう数3

みんなの回答 （1）
専門家の回答

質問者が選んだベストアンサー

ベストアンサー

real beatin（@realbeatin）
ベストアンサー率82% (174/211)

2017/04/27 00:03 回答No.1

こんにちは。さしあたり、当該サイトの利用規約については、そちらでご確認の上、ご検討くださいね。こちらも納期が迫ってあまり時間取れなくて本件にもなかなか着手する余裕がなく返答が遅れましたが、こちらで出来ることとしては、 <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"に替えている理由のひとつは、今回のような事例が他にもある、という含みがあってのことです。以上、ご参考まで。

質問者

お礼 2017/04/27 01:08

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

関連するQ&A

エクセルMSXML2で株価取得
標題の件で、エクセルのマクロでMSXML2を用いて"株探"というサイトの"本日、年初来高値を更新した銘柄"の全ページのテーブル(stock_table)内の<td>の値をエクセルに取得したいのですが、エラーが解決できないのでどう直せばいいか困っています。【参考サイト、備考】エクセルの神様 > マクロVBA > マクロVBAサンプル集 > WEBデータの取得方法 http://excel-ubara.com/excelvba5/EXCELVBA222.html のサイトのSample3(MSHTML.HTMLDocument)を参考にして書いたときは動作をしましたが複数ページ読み取る際にマクロがフリーズしてしまい、同サイトのSample4（MSXML2.XMLHTTP＋MSHTML.HTMLDocument）で書き直そうとして上手くいかず、エラーで止まってしまう状態です(オブジェクトの操作がよく分かってないです) 【プログラム】 ' ' // 'スリープ設定 #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 '株探新高値1ページ目URL　https://kabutan.jp/warning/?mode=3_3&market=0&stc=&stm=0&page=1 '株探テーブルclass名：stock_table 'ＶＢＥにて参照設定(MSXML2.XMLHTTP):Microsoft XML, v3.0、Microsoft HTML Object Library Sub kabutan_shintakane() Dim i1 As Long 'エクセル現在入始行 Dim j1 As Long 'エクセル現在入力列 Dim i2 As Long 'テーブル行 Dim j2 As Long 'テーブル列 Dim Judge As Long '処理終了判定 Dim URLpage As Long 'URL現在ページ番号 Application.Cursor = xlWait 'カーソル砂時計 i1 = 2 'シート行開始位置 j1 = 3 'シート列開始位置 Judge = 10 URLpage = 1 'URL開始ページ番号 Do While Judge > 1 i2 = 0 '初期化 j2 = 0 '初期化 Dim objXML As New MSXML2.XMLHTTP Dim htmlDoc As Object Set htmlDoc = New MSHTML.HTMLDocument Dim objTable As HTMLDocument 'HTMLテーブルオブジェク Dim objITEM As Object 'HTMLセルオブジェクト With objXML .Open "GET", "https://kabutan.jp/warning/?mode=3_3&market=0&stc=&stm=0&page=" & URLpage, False 'URL入力 .send (Null) htmlDoc.write .responseText End With Sleep (10) Set objTable = htmlDoc.getElementsByClassName("stock_table")(0) '←型が合わなくてエラーになります For Each objITEM In htmlDoc.getElementsByTagName("td") Cells(i, j) = objITEM.innerText j = j + 1 If j > 10 Then j = 1 i = i + 1 End If Next i1 = i1 + objTable.Rows.Length - 1 '次のシート行位置 Judge = objTable.Rows.Length 'URL次ページ読み取るか判定 URLpage = URLpage + 1 '次のページ位置 Set objXML = Nothing '初期化 Set htmlDoc = Nothing '初期化 Set objTable = Nothing '初期化 Set objITEM = Nothing '初期化 Loop Application.Cursor = xlDefault 'カーソル矢印 End Sub ' ' // ご教授お願いいたします。
- ベストアンサー
- Excel（エクセル）
Excel VBAについて
早速ですがExcelVBAについて質問です。年齢がN列にあるとき、M列に年代を入れたいと思います。（例：19才なら10代、30才なら30代）以下のように作成しましたが、すべてに20と入ったり正常に動作しないときがあります。 Excelは2003で作成していますが、いずれ2007でも使いたいです。もっと正確に実行できるコードを教えてください。ワークシート関数での解決は望んでいません。データ数も多く他の作業もマクロで処理するのでマクロを希望しています。よろしくお願いします。 -------------------------- Sub ByAge() Range("N1").Value = "年代別" Dim i As Long, N As Integer For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, 13).Value >= 60 And Cells(i, 13).Value < 70 Then Cells(i, 14).Value = 60 ElseIf Cells(i, 13).Value >= 50 And Cells(i, 13).Value < 60 Then Cells(i, 14).Value = 50 ElseIf Cells(i, 13).Value >= 50 And Cells(i, 13).Value < 60 Then Cells(i, 14).Value = 40 ElseIf Cells(i, 13).Value >= 30 And Cells(i, 13).Value < 40 Then Cells(i, 14).Value = 30 ElseIf Cells(i, 13).Value >= 20 And Cells(i, 13).Value < 30 Then Cells(i, 14).Value = 20 End If Next i MsgBox "完了！" End Sub --------------------------
- ベストアンサー
- オフィス系ソフト
VBA どこでもセル選択
教えて頂いたＶＢＡなのですがもう一つ Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j Counter = Counter + 1 If INP <> "" Then wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub -------------------------------------------------------------- For i = 3　のところを3としないでどのセル（行）にも対応させたいのですがどうすればいいでしょうか？
- ベストアンサー
- Excel（エクセル）
VBAで行列を作る方法
次のようなプログラミングで１，０，－１の要素で作られる3×3行列を全通り調べています。この場合３の９乗通り調べることができます。これを4×4や５×５行列など数を大きくして調べたいのですが、このプログラムを配列を使うなどして簡単にできる方法を教えてください。よろしくおねがいします。 Sub test() Dim a As Integer '行 Dim b As Integer '列 Dim c As Integer, i As Integer, j As Integer, d As Integer, e As Integer Dim 内積 As Integer, step As Integer Dim f As Integer, g As Integer, h As Integer, l As Integer, m As Integer, n As Integer, k As Integer, x As Integer Dim sum As Integer, total As Integer Dim aa As Integer, aaa As Integer, aaaa As Integer, bb As Integer, bbb As Integer, bbbb As Integer a = 3 '行 b = 3 '列 c = 0 内積 = 0 con = 0 sum = 0 tatal = 0 aa = 0 aaa = 0 aaaa = 0 bb = 0 bbb = 0 bbbb = 0 x = 0 For n = 0 To 2 For m = 0 To 2 For l = 0 To 2 For k = 0 To 2 For h = 0 To 2 For g = 0 To 2 For f = 0 To 2 For e = 0 To 2 For d = 0 To 2 '要素がすべて１ For i = 1 To a For j = 1 To b Cells(i, j) = 1 Next j Next i If bbbb = 1 Then Cells(a - 2, b - 2) = 0 ElseIf bbbb = 2 Then Cells(a - 2, b - 2) = -1 End If If bbb = 1 Then Cells(a - 1, b - 2) = 0 ElseIf bbb = 2 Then Cells(a - 1, b - 2) = -1 End If If bb = 1 Then Cells(a, b - 2) = 0 ElseIf bb = 2 Then Cells(a, b - 2) = -1 End If If aaaa = 1 Then Cells(a - 2, b - 1) = 0 ElseIf aaaa = 2 Then Cells(a - 2, b - 1) = -1 End If If aaa = 1 Then Cells(a - 1, b - 1) = 0 ElseIf aaa = 2 Then Cells(a - 1, b - 1) = -1 End If If aa = 1 Then Cells(a, b - 1) = 0 ElseIf aa = 2 Then Cells(a, b - 1) = -1 End If If total = 1 Then Cells(a - 2, b) = 0 ElseIf total = 2 Then Cells(a - 2, b) = -1 End If If sum = 1 Then Cells(a - 1, b) = 0 ElseIf sum = 2 Then Cells(a - 1, b) = -1 End If If con = 1 Then Cells(a, b) = 0 ElseIf con = 2 Then Cells(a, b) = -1 End If con = con + 1 Next d con = 0 sum = sum + 1 Next e sum = 0 total = total + 1 Next f total = 0 aa = aa + 1 Next g aa= 0 aaa = aaa + 1 Next h aaa = 0 aaaa = aaaa + 1 Next k aaaa = 0 bb = bb + 1 Next l bb = 0 bbb = bbb + 1 Next m bbb = 0 bbbb = bbbb + 1 Next n End Sub
- ベストアンサー
- オフィス系ソフト
ExcelのＶＢＡで質問です。
以下のようなシートがあります。 A列　　Ｂ列　　Ｃ列　　Ｄ列　　Ｅ列　　Ｆ列　　Ｇ列　　Ｈ列ＮＯ　　名前　　確認　日付1　日付2　　確認　日付1　日付2 6行目からデータを入れる予定です。Ｃ列には○印を入力します。Ｃ列～Ｅ列までデータが入った行は、Ｆ列～Ｈ列まで同じ処理をします。（セルの背景色を変えます。）以後同じことを列方向で繰り返します。以下のようなＶＢＡを組みましたが、 ○の個数を数える部分でエラーがでます。 Private Sub Worksheet_Change(ByVal Target As Range) Dim staff As String Dim kakunin As String Dim date1 As Date Dim date2 As Date Dim i As Long Dim j As Long Dim cnt As Long '100件分ループ For i = 6 To 105 '○の数をカウント cnt = WorksheetFunction.CountIf(ActiveSheet.Range(Cells(i, 2), Cells(i, 256)), "○") 'jとは確認の列番号のこと j = 3 * cnt staff = Cells(i, 2) kakunin = Cells(i, j) date1 = Cells(i, j + 1) date2 = Cells(i, j + 2) 'スタッフ名が入力されたら If staff = "" Then Range(Cells(i, j), Cells(i, j + 50)).Interior.ColorIndex = 15 Else Cells(i, j).Interior.ColorIndex = xlNone '○が入力されたら If kakunin = "○" Then Range(Cells(i, j + 1), Cells(i, j + 2)).Interior.ColorIndex = xlNone Else Range(Cells(i, j + 1), Cells(i, j + 2)).Interior.ColorIndex = 15 End If If Cells(i, j + 1) <> "" And Cells(i, j + 2) <> "" Then Cells(i, j + 3).Interior.ColorIndex = xlNone End If End If Next i End Sub ご教授いただけたら、幸いです。よろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
EXCEL VBA2010　MsgBox
Sub 重複() Dim i As Long, j As Long For i = 6 To 500 For j = 3 To 3 If WorksheetFunction.CountIf(Range("C6:C500"), Cells(i, j)) > 1 Then Cells(i, j).Interior.ColorIndex = 6 End If Next j Next i End Sub このVBAに重複が何件ありますよというメッセージを出したいです。 MsgBoxの入れ方を教えてください。
- ベストアンサー
- Excel（エクセル）
VBAでの質問
お世話になります。下記の記述で、「←」の矢印の記述で、 Cells.（５，２）がブランクでなければ、「→」から進めたいのですが、どの様に記述すれば宜しいでしょうかご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)　　← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub
- ベストアンサー
- Visual Basic
ＶＢＡの記述で、あるシートを別ファイルにした場合
エクセル2002で、商品を管理しています。１列目に品番をいれると、２列目に品名が表示するようにし、新規の品番は品名を入れると、追加登録されるようにＶＢＡを組みました。今度、このシート"商品"を別ファイル(商品.xls)にしたいと思うのですが、どうしても、やり方が分かりません。よろしくお願いします。 Public Sub Worksheet_Change(ByVal Target As Excel.Range) Dim 品番 As String Dim 品名 As String Dim i As Long With Target If .Column = 1 Then 品番 = .Text For i = 1 To 65536 If Sheets("商品").Cells(i, 1) = "" Then ActiveSheet.Cells(.Row, 2) = "" Exit For ElseIf 品番 = Sheets("商品").Cells(i, 1) Then ActiveSheet.Cells(.Row, 2) = Sheets("商品").Cells(i, 2) Exit For End If Next i End If If .Column = 2 Then 品名 = .Text 品番 = ActiveSheet.Cells(.Row, 1) If 品名 = "" Or 品番 = "" Then Else For i = 1 To 65536 If Sheets("商品").Cells(i, 1) = "" Then Sheets("商品").Cells(i, 1) = 品番 Sheets("商品").Cells(i, 2) = 品名 Exit For ElseIf 品番 = Sheets("商品").Cells(i, 1) Then Exit For End If Next i End If End If End With End Sub
- ベストアンサー
- オフィス系ソフト
VBA 空白表示させたい
教えて頂いたＶＢＡなのですが Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents If Selection(Selection.Count).Row <> 2 Then Exit Sub Counter = 0 For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j If INP <> "" Then Counter = Counter + 1 wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub ---------------------------------------------------------------------- ｇ　　　　　　ｈ　　　　　　　ｉ　　　　　　ｊパセリクレソンメキャベツの葉ごぼう１　　　　　　１　　　　　　　　　　　　　１１　　　　　　　　　　　　　　　　　　　　１ 1行目　パセリ,クレソン,メキャベツの葉 2行目　 3行目　パセリ,メキャベツの葉と、2行目は詰めずに空白表示したいです。どこをどうすればできますか？
- ベストアンサー
- Excel（エクセル）
ＶＢＡについて教えてください。
職場のエクセルのＶＢＡを見ていたら、下記のように書かれていました。ＶＢＡを勉強し始めたばかりで何が書かれているのか解りません。お手数ですが教えてください。よろしくお願いします。 Function F_Crypt(Data As Long, Seed As String) As Long Dim i As Long, j As Integer, act1 As Long, act2 As Long, iSeed As String If Len(Seed) > 3 Then j = 3 Else j = Len(Seed)
- ベストアンサー
- オフィス系ソフト