「A」「B」「C」「D」のすべての語句があれば○

質問

下記のマクロは、「A」があったら○を付けるというものです。

「A」があったら・・・というのを、
「A」「B」「C」「D」のすべての語句があれば○、というようにしたいです。

それは、どのような記述に変更すればできるでしょうか？
よろしくお願いいたします。

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
Application.Goto aCell
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
On Error Resume Next
xHttp.send
If xHttp.readyState <> 4 Then
xHttp.waitForResponse 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, "A")
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If
Else
aCell.Offset(, 1).Value = myErr_Description

DoEvents
End If
Next
Set xHttp = Nothing
End Sub

回答No.9

superside0 · ベストアンサー

あ、すいません。No.8では、
in_strm.Charset = "_autodetect"
で自動解析させてますが、
これだと、もともとUTF-8だったときに、誤認識して文字化けするかもしれない。
なので、HTML中のcharsetを調べて
in_strm.Charset 　に　指定したほうがよいかもです。

たとえば、
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, "ニキビ") > 0 And InStr(sHtml, "改善") > 0 And InStr(sHtml, "メイク") > 0 Then
aCell.Offset(, 1).Value = "○"
Else
aCell.Offset(, 1).Value = "--"
End If
みたいに。

もちろん、今回の件の原因が　文字化けだったら　の話ですが…

お礼

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

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
Application.Goto aCell
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
On Error Resume Next
xHttp.send
If xHttp.readyState <> 4 Then
xHttp.waitForResponse 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, "B") > 0 Then
aCell.Offset(, 1).Value = "○"
Else
aCell.Offset(, 1).Value = "--"
End If

Else
aCell.Offset(, 1).Value = myErr_Description

DoEvents
End If
Next
Set xHttp = Nothing
End Sub

これで、作業ができるようになりました！

１点だけ、URLを調べていくと途中で、
実行時エラー3001「引数が間違った型、許容範囲外、または競合しています。」
というポップが出て、頻繁に止まります。

これは、何かの記述で避けることができるようになるでしょうか？

回答No.3

kkkkkm

> マクロの記述が間違っているのでしょうか？

うちで該当のマクロをコピペしたら
If xHttp.readyState <> 4 Then Err.Raise 1004, ,
ここが構文エラーになるので実行テストができませんでした。

ソースで見ても検索している3文字列は存在してますから、うまくGETできているかどうかsHtmlをセルに書き出してみてはいかがでしょう。
encoding="Shift_JIS
だからという事もないとは思いますが…。HTMLは分かりませんm(__)m

回答No.2

maiko04

要素が増えたらこういうのも

nRtn = InStr(sHtml, "A")
nRtn = nRtn+InStr(sHtml, "B")
nRtn = nRtn+InStr(sHtml, "C")
nRtn = nRtn+InStr(sHtml, "D")

If nRtn = 4 Then
aCell.Offset(, 1).Value = "○"
Else
aCell.Offset(, 1).Value = "--"
End If

お礼

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

実際にやってみました。
例えば、
http://xn--ncka8a8dwbt6kza0d9d.com/
このサイトに対して、
nRtn = InStr(sHtml, "ニキビ")
nRtn = nRtn + InStr(sHtml, "対策")
nRtn = nRtn + InStr(sHtml, "改善")

If nRtn = 3 Then

で調べると、◯が付きました。

ですが、『ニキビ』『改善』『メイク』というキーワードがないサイトにも、
◯が付いてしまうようになります。

元のマクロの記述が間違っているのでしょうか？

回答No.1

kkkkkm

多分ABCDとかは実際は何かの文字列だと思いますが

nRtn = InStr(sHtml, "A")
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If
↑ここの部分を以下のようにしてはいかがでしょう、
If InStr(sHtml, "A") = 0 Or InStr(sHtml, "B") = 0 Or InStr(sHtml, "C") = 0 Or InStr(sHtml, "D") = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If

お礼

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

実際にやってみたところ、
ちゃんと◯が付かないサイトがあるようです。

例えば、
http://xn--ncka8a8dwbt6kza0d9d.com/
このサイトに対して、
If InStr(sHtml, "ニキビ") = 0 Or InStr(sHtml, "改善") = 0 Or InStr(sHtml, "メイク") = 0 Then
で調べてみても、◯が付きません。

このサイトには、『ニキビ』『改善』『メイク』が含まれています。
ですが、◯が付かない。

マクロの記述が間違っているのでしょうか？