サイトタイトルに、指定した語句があれば○

質問

下記のマクロは、指定範囲のURL先のソースに、
指定した語句があれば、○を付けるマクロです。

指定した語句をソース全て対象にせずに、
<title></title>のサイトタイトルの中にあれば、○を付けるというようにしたいです。

ちなみに、調べたいのは語句ではないですが、"【"というカッコです。

・下記のマクロ
URL先のソース全体の中に、指定した語句があれば○

・希望のマクロ
<title></title>（サイトタイトル）の中に、指定した語句があれば○

どの部分を修正、または追加すればできるようになりますか？
よろしくお願いいたします。

Sub 指定した語句()
'!!!! [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, "指定した語句")
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.1

kkkkkm · ベストアンサー

> 調べたいのは語句ではないですが、"【"というカッコです

nRtn = InStr(sHtml, "指定した語句")
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If

の部分を

If sHtml Like "*<title>*" & "【" & "*</title>*" Then
aCell.Offset(, 1).Value = "○"
Else
aCell.Offset(, 1).Value = "--"
End If

に変更して試してみてください。

補足

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

早速、マクロを変更してやってみました。
すると、"【"があるのに、ちゃんと"○"が付くのと"--"になってしまうのがあります。

例えば、以下のURLは両方ともタイトルに"【"があります。
ですが、
https://kokuei-tcc.co.jp/
は、○が付きますが、
https://ihan.jp
は、--になってしまいます。

"【"がある両方のURLに、○が付くようにできるでしょうか？
よろしくお願いいたします。

回答No.4

kkkkkm

> どういった記述を足すのでしょうか？

HTMLの事についてはよくわかりませんので

元のコードの一部を以下に変更したものを記載して

If sHtml Like "*<title>*" & "【" & "*</title>*" Then
aCell.Offset(, 1).Value = "○"
Else
aCell.Offset(, 1).Value = "--"
End If

"【"がUTF-8のサイトだと認識できるのだが、Shift_JISのサイトでは認識できないのでどうすればいいか、という質問を新たに出してください。その際この質問は締め切ってください。

回答No.3

imogasi

「どんなことを質問しているのか」と思って，微修正して、小生が簡単な例で数件やってみました。参考に。
＃２のご指摘の点など考慮で来てませんが。
シートC列に、WEB記事のタイトルのテキストを出してみました。
ーー
これより先の最終目的達成については判りません。
Sub 指定した語句()
'!!!! [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
'------------------当シートのA列のデータある業を範囲指定しておいて実行のこと
'------------------VBAでも出来るが質問のまま
R = 1
For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL
'Set aCell = Worksheets("Sheet1").Cells(aceii.Row, "A")
'MsgBox aCell.Value
Application.Goto aCell '対象URLの列にジャンプ表示
DoEvents
surl = aCell.Value
'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 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
Debug.Print sHtml
nrtn = InStr(sHtml, "<title>")
If nrtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
'見つかった
nrtn2 = InStr(sHtml, "</title>")
aCell.Offset(0, 1).Value = "○"
aCell.Offset(0, 2).Value = Mid(sHtml, nrtn + 7, nrtn2 - (nrtn + 7))
End If
Else
aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示
End If
DoEvents
End If
Next
'-----------------------
Set xHttp = Nothing
End Sub

補足

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

調べたいURLが１０万を越えており、
できるだけ早く調べていくマクロが必要と感じております。

サイトタイトルも取得できたら、ありがたいのですが、
タイトルに"【"が入っているか否か、これを調べていきたいです。

サイトによっては、文字コードがShift_JISのものがあるようで、
これを変換して調べて、１０万URLの中から目的のものを取得したいです。

文字コードがShift_JISをUTF-8に変換して取得するには、
どのようなマクロの記述になりますでしょうか？

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

回答No.2

kkkkkm

> https://ihan.jp
> は、--になってしまいます。

文字コードがShift_JISだからですね。
データを読み込んだ時にShift_JISをUTF-8に変換して操作すればいいと思います。やりかたは調べてみてください。

補足

返信ありがとうございます。
すみません。
こちらのマクロは、前に書いてもらったものであり、
私自身はマクロの知識がまったくない状態です。

＞データを読み込んだ時にShift_JISをUTF-8に変換して操作
というのは、どういった記述を足すのでしょうか？
よろしくお願いいたします。