こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

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

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
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

投稿日時 - 2019-07-22 02:07:39

QNo.9637860

困ってます

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

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

投稿日時 - 2019-07-22 09:15:13

ANo.2

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

ベストアンサーを頂いた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

投稿日時 - 2019-07-22 15:12:16

ANo.4

>キーワードが全部あるのに
分かっているのだろうが、質問のコードは、「指定の5語のどれかがあれば」になっている。
Strは見つかった位置の数字を返し、見つかれば1以上になる。それら5つをを足せば、どれも見つからない時のみ0になるはず。
ーー
テストのやり方なども、質問に、書いておくのが読者への礼儀だろう。
例えばA列の複数セルに、チェックしたいURLをそれぞれ入力する。
その全セル範囲を範囲指定しておいて実行。<--
この部分は、ちゃんとしたか?小生の似た経験から、つい忘れやすい。
うまく行かないURL例1つぐらい質問に書くべきではないか?
ーー
小生がやってみたところ、5,6件の勝手なURLでは、うまく行ったようだが。
最後に言いたいことは、xHttp.waitForResponse 15 にしてみた(延長)。
その他は質問のコードに進行確認用MsgBoxを入れただけ。
ーー
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
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

投稿日時 - 2019-07-22 10:16:18

ANo.3

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

投稿日時 - 2019-07-22 10:15:15

ANo.1

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

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

投稿日時 - 2019-07-22 08:24:16

あなたにオススメの質問