キーワードが全部あるのに、○が付かない

質問

下記のマクロは、URL先のソースの中に、
「赤ちゃん」「妊婦」「ママ」「水」「ウォーター」
のどれかがあれば、隣に○を付けるというものです。

ですが、
https://www.andrea-pennington.com/
こちらのサイトを調べたところ、
キーワードが全部あるのに、○が付かず--でした。

マクロの記述がどこかおかしいでしょうか？

ソースの中に、どれかのキーワードがあれば、
○が付くようにするには、どのような記述になるでしょうか？

Excel２０１６です。
よろしくお願いいたします。

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
nRtn = InStr(sHtml, "赤ちゃん") + InStr(sHtml, "妊婦") + InStr(sHtml, "ママ") + InStr(sHtml, "水") + InStr(sHtml, "ウォーター")
　　　　　　　　　If nRtn = 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

kkkkkm · ベストアンサー

ShftJISのページが駄目だったと思いますので
以下のようにしてみてはいかがでしょう。

sHtml = xHttp.responseText
CharsetS = InStr(1, xHttp.responseText, "charset=")
CharsetE = InStr(CharsetS, xHttp.responseText, ">")
CharsetStr = Mid(sHtml, CharsetS + 9, CharsetE - CharsetS - 10)
If CharsetStr = "Shift_JIS" Then
sHtml = StrConv(xHttp.responseBody, vbUnicode)
End If

回答No.5

kkkkkm

ベストアンサーを頂いたNo2ですが、文字数をきっちり決めているのでガチガチな感じになってしまいました。以下の方が「Shift_JISを含む」にしているので多少前後の文字が増減しても対応できるのでいいのではないかと思います。

sHtml = xHttp.responseText
CharsetS = InStr(1, xHttp.responseText, "charset")
CharsetE = InStr(CharsetS, xHttp.responseText, ">")
CharsetStr = Mid(sHtml, CharsetS, CharsetE - CharsetS)
If InStr(CharsetStr, "Shift_JIS") Then
sHtml = StrConv(xHttp.responseBody, vbUnicode)
End If

回答No.4

imogasi

>キーワードが全部あるのに
分かっているのだろうが、質問のコードは、「指定の５語のどれかがあれば」になっている。
Ｓｔｒは見つかった位置の数字を返し、見つかれば１以上になる。それら５つをを足せば、どれも見つからない時のみ０になるはず。
ーー
テストのやり方なども、質問に、書いておくのが読者への礼儀だろう。
例えばＡ列の複数セルに、チェックしたいＵＲＬをそれぞれ入力する。
その全セル範囲を範囲指定しておいて実行。＜－－
この部分は、ちゃんとしたか？小生の似た経験から、つい忘れやすい。
うまく行かないＵＲＬ例１つぐらい質問に書くべきではないか？
ーー
小生がやってみたところ、５，６件の勝手なＵＲＬでは、うまく行ったようだが。
最後に言いたいことは、xHttp.waitForResponse 15　にしてみた（延長）。
その他は質問のコードに進行確認用MsgBoxを入れただけ。
ーー
Ｓub 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
nRTN = ""
MsgBox sUrl
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 15 '15秒まってだめならタイムアウト
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
MsgBox sHtml
nRTN = InStr(sHtml, "赤ちゃん") + InStr(sHtml, "妊婦") + InStr(sHtml, "ママ") + InStr(sHtml, "水") + InStr(sHtml, "ウォーター")
If nRTN = 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
MsgBox "終了"
End Sub

回答No.3

watabe007

No.1です。
nRtn = InStr(sHtml, "赤ちゃん") + InStr(sHtml, "妊婦") + InStr(sHtml, "ママ") + InStr(sHtml, "水") + InStr(sHtml, "ウォーター")
この場合、初期化は不要でしたね、失礼しました。

回答No.1

watabe007

For Each で回しているのだから nRtnは都度、初期化しなければ

nRtn = 0
nRtn = InStr(sHtml, "赤ちゃん") + InStr(sHtml, "妊婦") + InStr(sHtml, "ママ") + InStr(sHtml, "水") + InStr(sHtml, "ウォーター")