「実行時エラー3001」のポップが出てしまう

下記のマクロでは、A列にあるURLのソースに、
指定した語句が含まれているか調べるものです。

このマクロを動かしていると、頻繁に、
実行時エラー3001「引数が間違った型、許容範囲外、または競合しています。」
というポップが出てきます。

そのため、思うようにマクロ作業が進みません。

このエラーが出る原因は何があるでしょうか？
エラーが出ないようにするためには、どのように記述した方がいいでしょうか？

それか、このエラーのポップを避けて、
その次のURLから動かしていくという風にできたりしますでしょうか？


実行時エラーのときデバッグボタンをクリックすると、
in_strm.Charset = sCharset
の部分が黄色マーカーになっています。


エラーが出たURLの一部は、これらです。
https://www.apo-job.jp/
https://www.aniel.jp/
https://www.amo-co.jp/


バージョンは、Excel2016です。


よろしくお願いいたします。




Sub main()
'!!!! [Microsoft XML v6.0] に参照設定すること
Dim xHttp As IServerXMLHTTPRequest
Dim myErr_Number As Long, myErr_Description As String
Set xHttp = CreateObject("MSXML2.ServerXMLHTTP")
Dim aCell As Range
R = 1
For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL
Application.Goto aCell '対象URLの列にジャンプ表示
DoEvents
sUrl = aCell.Value
If sUrl <> "" Then
xHttp.Open "GET", sUrl, True
xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _
SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視
On Error Resume Next
xHttp.send
If xHttp.readyState <> 4 Then
xHttp.waitForResponse 5 '5秒まってだめならタイムアウト
End If
If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト"
myErr_Number = Err.Number
myErr_Description = Err.Description
On Error GoTo 0
If myErr_Number = 0 Then

sHtml = xHttp.responseText
v1 = InStr(1, sHtml, "charset=") + 8
If (Mid(sHtml, v1, 1) = """") Then v1 = v1 + 1
v2 = InStr(v1, sHtml, """")
If (v2 > InStr(v1, sHtml, "/")) Then v2 = InStr(v1, sHtml, "/")
If (v2 > InStr(v1, sHtml, " ")) Then v2 = InStr(v1, sHtml, " ")
sCharset = Mid(sHtml, v1, v2 - v1)

Set in_strm = CreateObject("ADODB.Stream")
in_strm.Open
in_strm.Position = 0
in_strm.Type = 1
in_strm.Write xHttp.responseBody
in_strm.Position = 0
in_strm.Type = 2
in_strm.Charset = sCharset
sHtml = in_strm.ReadText

If InStr(sHtml, "A") > 0 And InStr(sHtml, "B") > 0 And InStr(sHtml, "C") > 0 Then
aCell.Offset(, 1).Value = "○"
Else
aCell.Offset(, 1).Value = "--"
End If


Else
aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示
End If
DoEvents
End If
Next
Set xHttp = Nothing
End Sub

No.2 ベストアンサー 回答者： siffon9 回答日時： 2019/07/15 11:33

> in_strm.Charset = sCharsetの手前に、

> On Error Goto xxxxを入れてみました。
> マクロを動かすと、『行ラベルが定義されていません。』と出ます。

いや、No.1は原因を調べるための方向性を提示しただけで、そのままプログラムに加えろをいう意味ではありません。
もしかしてVBAの各行の意味を理解されていないのですか？
「On Error Resume Next」を使用されているので理解されていると思ったのですが……

そうであるならば、文法から勉強されることをお勧めします。
「On Error Goto」の使い方は検索すれば、直ぐにみつかります。

この回答へのお礼

返信ありがとうございます！

申し訳ありません。
質問のマクロは、ネットにあったものです。

私自身、マクロに関する知識は皆無です。
ですが、どうしても今の作業を完了させないとならないです。

そのため、マクロのエラーをパスして、
次のURLから調べていくようにしたいです。


調べてみると、『On Error Goto』は、
エラーが起きた時に次の処理をする、というもののようですね。

エラーが出たら、すぐ下のセルに移行して調べ始める。
というのは出来るのでしょうか？

On Error Resume Nextと使うと思うのですが、
どのように記述すればいいかわからないです。

よろしければ、すぐ下のセルへ移行する記述を書いていただけたら幸いです。

お礼日時：2019/07/15 12:33

No.1 回答者： siffon9 回答日時： 2019/07/14 13:59

私の環境では、ご提示のURLでエラーになりませんでした（Win10 Excel365）

sCharset = Mid(sHtml, v1, v2 - v1)

で正しい文字セットの文字列（"UTF-8"等）が取得できていないのが原因です。
エラー発生時に、sCharset にどの様な文字列が代入されているか確認して
何故そうなるかを調べてはいかがでしょうか？

おそらく
　v1 = InStr(1, sHtml, "charset=") + 8
　If (Mid(sHtml, v1, 1) = """") Then v1 = v1 + 1
　v2 = InStr(v1, sHtml, """")
　If (v2 > InStr(v1, sHtml, "/")) Then v2 = InStr(v1, sHtml, "/")
　If (v2 > InStr(v1, sHtml, " ")) Then v2 = InStr(v1, sHtml, " ")
のあたりの処理が適切ではないのではないかと推測できます。


in_strm.Charset = sCharset の手前で On Error Goto xxxxを挿入して sCharsetの内容を表示させてみましょう。

この回答へのお礼

回答ありがとうございます！

in_strm.Charset = sCharsetの手前に、
On Error Goto xxxxを入れてみました。

マクロを動かすと、『行ラベルが定義されていません。』と出ます。
そして、一番最初の行の、『Sub ～ 』に黄色マーカーがついています。

これは、他の部分も変更しないとならないのでしょうか？

お礼日時：2019/07/15 09:50