「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.14

superside0

> エラーが出たURLの一部は、
>https://www.apo-job.jp/
>（charsetのところは、charset=euc-jp）
>https://www.aniel.jp/
>（charsetのところは、charset=UTF-8）
>https://www.amo-co.jp/
>（charsetのところは、charset="UTF-8）

もしかして　エラーが出るサイトは　https の　サイト集中していませんか？

というのも、上記、３サイトとも　私が実験してみたところ
"A security error occurred"
というエラーが、--や○が入るところにに埋まりました。
（コードの後ろから６行目のEnd if 抜けは、修正しましたが）

また、上記３サイトのHTMLを　一旦　手動でダウンロードして
仮のURLで本プログラムにかけた所、きちんとエラーなく判定できたので
これのHTML自体は、正しいみたいです。

また、正規のSSLサーバー証明書を使っているサイトだとhttpsでも、
きちんとエラーなく判定できました。

たまたまかもしれませんが、上記３サイトは、どれも
xserverというレンタルサーバーを使っていているようなのですが、
もしかして　これのSSL証明書が　SNI　というタイプなのかもしれません。
（大雑把にいうとブラウザがSNIに対応していないと接続できないタイプ）
そして、それが、　本プログラムの　MSXML2.ServerXMLHTTPでは、
上手く　接続できないのかもしれません。

xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _
SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
のオプション指定で
証明書のエラーを無視するような記述はあるのですが、
SNIは、リクエストするホスト名（URL)までは平文で、
その後から暗号に切り替わるなるという　ちょっと変わった通信なので。

もしこれが原因なら、　VBAからのHTML取得に、SNI対応する別の通信方法を選ぶか、
SNIに対応したコマンドライン系のダウンローダをVBAからシステムコールして、　
そのテンポラリファイルに対して、VBAからデータチェックを行うか

ってことになるでしょう。

（これ以上は、本気だして、ちゃんと調べないと、なんとも…）

お礼

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

> もしかして　エラーが出るサイトは　https の　サイト集中していませんか？
他のURLのhttpsは大丈夫でした。
そのため、SSLは関係ないかと思われます。

SSL証明書が関係して、かなり専門的になってきますね・・・。

何度も回答＆返信ありがとうございました。
動かせるマクロを書いていただけて、嬉しかったです。

作業を進めることができました。
ありがとうございました！

回答No.13

superside0

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

多分 HTMLから　charset=～　を取り出す処理のところで
うまく取り出せない記述の HTMLがあるのだと思われます。

HTMLのソースのcharsetのとこがどうなってるかや
sCharset変数　を　debug.print　するなりして、
調べてみて下さい。

もしくは、そのエラーがでてしまう、URLを教えて下さい。

お礼

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

エラーが出たURLの一部は、
https://www.apo-job.jp/
（charsetのところは、charset=euc-jp）
https://www.aniel.jp/
（charsetのところは、charset=UTF-8）
https://www.amo-co.jp/
（charsetのところは、charset="UTF-8）

他にも止まるURLはありますが、
基本、charset="UTF-8です。
一番上のだけ、charset=euc-jpでした。

回答No.12

watabe007

>「A」「B」「C」「D」のすべての語句があれば○
>nRtn = InStr(sHtml, "A")
>If nRtn = 0 Then
>　aCell.Offset(, 1).Value = "--"
>Else
>　aCell.Offset(, 1).Value = "○"
>End If

Dim Ver As Variant, flg As Boolean
For Each Ver In Array("A", "B", "C", "D")
　　If InStr(sHtml, Ver) = 0 Then flg = True
Next
If flg = True Then
　　aCell.Offset(, 1).Value = "--"
Else
　　aCell.Offset(, 1).Value = "○"
End If

回答No.11

imogasi

#５です。＃５では私の意図を組んでもたってません。また質問では、条件は４つであるのを、３つに簡略してます。それを察知して修正したのかどうか。
しかしそれは言いません。
ーー
小生は趣味で正規表現を勉強していて、正規表現で簡単にならないか、考えてみました。
例データ　Ａ１：Ａ１０
ニキビ対策の改善にこのメイクをどうぞ
腹痛対策改善にのメイクをどうぞ　
ニキビ対策の決定版にこのメイクをどうぞ　
しつこいニキビ対策決定版。改善にこのメイクをどうぞ　
しつこいかゆみ対策決定版。改善にこのメイクをどうぞ　
スキン対策決定版。改善にこのメイクをどうぞ　
スキン対策決定版。改善にこのメイクをどうぞ　
皮膚対策決定版。改善にこの薬をどうぞ　
皮ふニキビ対策決定版。スキン改善にこのメイクをどうぞ　
ニキビ対策決定版。スキン改善にこのメイクをどうぞ。よいメイクです。　
ーー
標準モジュールに
Sub test03()
'Microsoft vbscript reguler expresshion 参照設定
Dim RegMc As Variant
Dim str1 As String
Dim str2 As String
lr = Range("A1000").End(xlUp).Row
For i = 1 To lr
vl = Cells(i, "A")
'---

str1 = vl
str2 = ""
With CreateObject("VBScript.RegExp")
.Pattern = "ニキビ|スキン|メイク"
.Global = True
Set RegMc = .Execute(str1)
MsgBox i & "= " & RegMc.Count
If RegMc.Count >= 3 Then
str2 = RegMc(0) '抽出
MsgBox (str1 & "=" & str2)
End If
End With
Next i
End Sub
これを実行すると、
この例では、Pattern = "ニキビ|スキン|メイク"　と３語の例なので
RegMc.Count >= 3 　　なら条件を満たしているかと思った。
しかし１文の中に含まれる語が、ニキビースキンースキンだと、この設例の条件（最低でも指定３語は１回以上出現）を満たさない（語「メイク」がない）のにRegMc.Count >= 3 　を満たしてしまう。
これをカバーする正規表現は、力不測でわからない。
考えているケースでは、「ダブり出現がない」といえるなら使えるだろう。
＝＝＝
こういう分野・方法もあるということを紹介します。

回答No.10

kkkkkm

他の方へ補足を見たのですが
> https://xn--t8jpwa5c9i0a2269fe27ail0b.com/
> http://xn--ncka8a8dwbt6kza0d9d.com/
> 双方のサイトで、何か決定的な違いがあったりするのでしょうか？

文字コードが違つて、上はUTF-8で下は下はShift_JISでした。
Shift_JISだと駄目なんだと思いますから

sHtml=StrConv(xHttp.responseText , vbUnicode)

みたいな感じで変換してみてはいかがでしょう。

回答No.8

superside0

nRtn = InStr(sHtml, "A")
nRtn = nRtn+InStr(sHtml, "B")
nRtn = nRtn+InStr(sHtml, "C")
nRtn = nRtn+InStr(sHtml, "D")
If nRtn = 4 Then
だと、InStrは　ありなしを　False or True とか、0 or 1で　返す関数でなく、
見つけた文字列の先頭からの位置を返す関数なので、
この記述だと　誤動作すると思います。

また、３条件や４条件ぐらいなら　フラグを使ったり
3条件の積を作るのに、Orの裏を使ってわざわざややこしくしなくても、
Andの表　（つまり代入部を逆）にして
If InStr(sHtml, "ニキビ") > 0 And InStr(sHtml, "改善") > 0 And InStr(sHtml, "メイク") > 0 Then
　aCell.Offset(, 1).Value = "○"
Else
　aCell.Offset(, 1).Value = "--"
End If
で書いたほうが、見た目も、分かりやすいし、
あとあとも修正し易いように　思います。

で、肝心の文字列あるのに　発見できないのは、多分
sHtml = xHttp.responseText
で取り出してるので　VBAではこれを勝手にutf-8扱いして、
元がSJISだと文字化けしているからだと思われます。

なので、一旦　xHttp.responseBody　からバイナリのまま取り出して、
これを　手動で文字コード変換してやればよいかと。
具体的には、
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 = "_autodetect"
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

みたいな感じで。

回答No.7

kon555

>>○がつきませんでした
では「--」が入力されましたか？　それとも何も入力されませんでしたか？

いい機会だと思って、軽くデバックのやり方を覚えた方がいいように思います。
まず重要なのは『何がどうなったか』を正確に認識することです。今回のケースであれば『--と入力された』のと『何も入力されなかった』のでは有力な原因が変わってきます。
まずそれをしっかりと認識し、またこうしたサイトで質問する際には記載するようにしましょう。

またマクロを単純に実行するのではなく、F8のステップインで挙動を確認しながら実行していくのも効果的です。
そのようにしていけば、「そもそも文字列の認識に失敗している」のか「『全てに当てはまる』という判定部分で失敗している」のか「○の記入に失敗している」のかが分かるようになります。

長いマクロですし、一度貴方自身の環境でそれらを確認してみないと、中々有効な対策は出てこないと思いますよ。
https://www.excelspeedup.com/vbadebug/

お礼

説明不足すみません。「--」は入力されました。
そのため、ソース内の認識ができていないのかな？と思いました。

日本語ドメインをピュニコードで暗号化されているのも、
日本語ドメインに変えてやりましたが、「--」でした。

そのため、日本語ドメイン・ピュニコードは関係ないかと。

・HTMLで作られたサイト
・WordPressで作られたサイト

この違いがあるかもと思い、いろいろ試しましたが、
https://xn--t8jpwa5c9i0a2269fe27ail0b.com/
こちらのHTMLサイトは、ちゃんと「◯」が付きます。

WordPressで作られたサイトも、いくつか試しましたが、
マクロに記述した語句が一致して「○」が付きました。

おそらく、一部のHTMLサイト（http://xn--ncka8a8dwbt6kza0d9d.com/など）
がうまく行っていないようです。

このうまく行かないサイトとの違いを見つける。
または、別のアプローチでソースを認識して「◯」「--」を付けるようにする。
というのが良いかと思いました。

https://xn--t8jpwa5c9i0a2269fe27ail0b.com/
http://xn--ncka8a8dwbt6kza0d9d.com/
双方のサイトで、何か決定的な違いがあったりするのでしょうか？

回答No.6

kkkkkm

No3です。

もしかしたら
http://xn--ncka8a8dwbt6kza0d9d.com/
は
http://リプロスキンニキビ・.com/
にリダイレクトされてるから、リダイレクト用のHTML内で検索してヒットしないのではないでしょうか。

補足

http://xn--ncka8a8dwbt6kza0d9d.com/
は、ピュニコードで日本語に変換したのが、
リプロスキンニキビ・
のようです。

http://リプロスキンニキビ・.com/
でやっても、○が付きませんでした。

回答No.5

imogasi

質問がエクセルでないのは承知してますが、手軽なテストのためやってみた。
Ｉｎｓｔｒ関数を使うことを守ってやった。
ニキビ、対策、改善の３御をオール含むものＯＫ。
例データ　Ａ１：Ｂ４　Ａ列が例文。Ｂ列が結果ＯＫかＮＯ。
例文
ニキビ対策の改善にこのメイクをどうぞ OK
腹痛対策改善にのメイクをどうぞ 　NO
ニキビ対策の決定版にこのメイクをどうぞ 　NO
ニキビ対策決定版。改善にこのメイクをどうぞ 　OK
標準モジュールに
Sub test0()
For i = 1 To 4
vl = Cells(i, "A")
p = InStr(vl, "ニキビ")
If p = 0 Then GoTo no
p = InStr(vl, "対策")
If p = 0 Then GoTo no
p = InStr(vl, "改善")
If p = 0 Then GoTo no
Cells(i, "B") = "OK"
GoTo nx
no:
Cells(i, "B") = "NO"
nx:
Next i
End Sub
上記はＧｏＴｐ文があったりして、自慢じゃないが、気に食わなければ無視して。ロジックは何もむつかしくない。
条件が１つでも見つからなければ、脱落という考えで済む話。

補足

>質問がエクセルでないのは承知してますが、手軽なテストのためやってみた。
EXCELでマクロを動かしています。
カテゴリーは、EXCELの方が良かったでしょうか？

マクロをやってみましたが、NOが４つ表示されました。
URLのソースの中に、指定した語句がすべてある場合に◯が付く。
という形にしたいです。

回答No.4

kon555

「A」「B」「C」「D」の全てがあれば、なら別個にフラグ管理するのがいいと思いますよ。

nRtn = InStr(sHtml, "A")
If nRtn = 0 Then

のところを、
if InStr(sHtml, "A") <> 0 then i = i+1
if InStr(sHtml, "B") <> 0 then i = i+1
(以下CとDも同様に)
に変えます。

そして
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If
を

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

とします。これでいけると思いますよ。

不要かもしれませんが解説すると、元々のマクロは条件が1つだけなので、「Aが含まれるか、含まれないか」だけで直接判定しています。
それが
nRtn = InStr(sHtml, "A")
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If
の部分です。
しかし複数語句の「全てを満たす」というタイプなら、単純にフラグを4つ容易するのが簡単です。
これが
if InStr(sHtml, "A") <> 0 then i = i+1
の部分です。
これは語句が含まれる場合は変数ｉに1を足していくので、全て含まれる場合は、最終的に条件の数とiの数は等しくなります。
よって
If i < 4 Then
の条件で、○を付けるかつけないかが判定できるのです。
仮に語句の種類を増やす場合、この判定の「ｉ＜4」の部分も忘れずに変更してくださいね。

補足

If InStr(sHtml, "ニキビ") <> 0 Then i = i + 1
If InStr(sHtml, "対策") <> 0 Then i = i + 1
If InStr(sHtml, "改善") <> 0 Then i = i + 1
If i < 3 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If
でやってみましたが、○が付きませんでした。

If i < 4 Then、If i < 3 Thenの両方でも駄目でした。
他の部分のマクロが違うのでしょうか？