重要なお知らせ

「教えて! goo」は2025年9月17日(水)をもちまして、サービスを終了いたします。詳細はこちら＞

電子書籍の厳選無料作品が豊富！

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

解決済

  • 質問者：hatehatewa
  • 質問日時：
  • 回答数：7件

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

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

質問者からの補足コメント

  • みなさま、回答ありがとうございます！

    実はこのマクロは、ネットで拾ったもので、
    自分で書いたものではありません。

    なので、Function～をどこに記述すればいいのか、から躓きます。


    「●●」「▲▲」「■■」の複数の語句も、
    どこに記述すればいいか分からず・・・。

    一つ、マクロを書いていただけたら幸いです。
    よろしくお願いいたします。

      補足日時：2019/07/09 05:19
    通報する
通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (7件)

No.6ベストアンサー

ごめんなさい。


早速間違いを見つけました。動作確認もしたのでこれでOKです。
標準モジュールにコピれば大丈夫です。

Option Explicit
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, sUrl As String, sHtml As String, nRtn As Integer
Dim String1 As String, String2 As String, String3 As String

String1 = "指定した語句": String2 = "指定した語句2": String3 = "指定した語句3"

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 = InStrTitle(sHtml, String1) + InStrTitle(sHtml, String2) + InStrTitle(sHtml, String3)
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
MsgBox "--"
Else
aCell.Offset(, 1).Value = "??"
MsgBox "??"
End If
Else
aCell.Offset(, 1).Value = myErr_Description
MsgBox myErr_Description
End If
DoEvents
End If
Next
Set xHttp = Nothing
End Sub

Function InStrTitle(sHtml As String, SearchStr As String) As Integer
InStrTitle = InStr(Mid(sHtml, InStr(sHtml, "<title>"), InStr(sHtml, "</title>") - InStr(sHtml, "<title>") + 1), SearchStr)
End Function
    • good
    • 0
    • 件
通報する
この回答へのお礼

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

実際にやってみて、動きました。
マクロありがとうございます！

１点、一つのURLの度にポップアップが出るのですが、
これを出ないようにして、次々と調べていくようにはできるでしょうか？

通報する
お礼日時：2019/07/10 22:25

No.7

コードのMsgBoxと書いてある行を全部消したら、


ポップアップは出ません。

MsgBoxは行の左端をじーっと見ていくと3箇所あります。
    • good
    • 0
    • 件
通報する
この回答へのお礼

ポップアップを消すことができました。
ありがとうございます！

通報する
お礼日時：2019/07/10 23:09

No.5

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
Dim String1 As String = "調べたい語句１", String2 As String = "調べたい語句2"
,String3 As String = "調べたい語句3" //ここに調べたい語句を書いておく

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 = InStrTitle(sHtml, String1) + InStrTitle(sHtml, String2) + InStrTitle(sHtml, String3)
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


Function InStrTitle( sHtml As String, SearchStr As String) As Integer
InStrTitle = Instr( Mid( sHtml, InStr(sHtml, “ <title>”),
InStr(sHtml, “</title>”)- InStr(sHtml, “ <title>”)+ 1, SearchStr)
End Function

これでいいはず。です。
バグってたら言ってください。
    • good
    • 0
    • 件
通報する

No.4

回答したやつを3つも書くと長いので


例えば

Function InStrTitle( sHtml As String, SearchStr As String) As Integer
InStrTitle = Instr( Mid( sHtml, InStr(sHtml, “ <title>”), Instr(sHtml, “</title>”)- InStr(sHtml, “ <title>”)+ 1, SearchStr)
End Function

というのを作って
InStrTitle(sHtml, “指定した語句”) Or InStrTitle(sHtml, “指定した語句2”) Or ...
がTrueだったら○になります。
    • good
    • 0
    • 件
通報する

No.3

  • 回答者： fujillin
  • 回答日時：

No2です。



すみません。URL書き忘れたみたいです。
https://tonari-it.com/excel-vba-http-document-wr …
    • good
    • 0
    • 件
通報する

No.2

  • 回答者： fujillin
  • 回答日時：

こんにちは



横からですが・・・

＞制限させて調べる場合は、
＞どのような記述になるでしょうか？
ご提示のsHtmlの代わりに、タイトルタグの内容だけの文字列を対象に、同様の処理を行えばよいのでは？

一応、変数を別にして
　s = Mid(sHtml, InStr(sHtml, "<title>") + 7)
　s = Left(s, InStr(s, "</title>") - 1)
などとしておけば、タイトルの内容が変数sに入りますので、後は、これを用いるようにすれば宜しいかと。。

タイトルタグの場合には、属性値が設定されている可能性は少ないので<title></title>決め打ちでも大抵の場合は大丈夫でしょうけれど、属性値が設定されていたり、タグ内にスペースが入っていたりすると、上記のような単純な検索ではうまくいかない可能性があります。

確実を期するなら、responseTextをhtml化（DOM化）して、getElementsByTagNameメソッドなどで抜き出すなどでしょうか。
以下のサイトのページ後半に記されている方法で可能かと思います。
    • good
    • 0
    • 件
通報する

No.1

nRtn = InStr(sHtml, "指定した語句")を


nRtn = InStr( Mid( sHtml, InStr(sHtml,"<title>") , InStr(sHtml,"</title>")-InStr(sHtml,"<title>") ),
"指定した語句")

とすれば、”<title>”から"</title>"までの文字列のなかで　”指定した語句”　を検索することができます。
バグってたら教えてください。
    • good
    • 0
    • 件
通報する
この回答へのお礼

回答ありがとうございます！
質問に、一つ書き忘れていました。

「指定した語句」の他にも、「指定した語句２」「指定した語句３」、
つまり、<title></title>の中に、「●●」「▲▲」「■■」のどれかが含まれていたら、
隣のセルに○を付ける。という風にしたいです。

ソース全体で調べるなら、
nRtn = InStr(sHtml, "●●") + InStr(sHtml, "▲▲") + InStr(sHtml, "■■")
で出来ると思うのですが、制限させて調べる場合は、
どのような記述になるでしょうか？

通報する
お礼日時：2019/07/07 22:44

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報