
下記は、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
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
回答ありがとうございます!
実際にやってみて、動きました。
マクロありがとうございます!
1点、一つのURLの度にポップアップが出るのですが、
これを出ないようにして、次々と調べていくようにはできるでしょうか?
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 = "調べたい語句1", 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
これでいいはず。です。
バグってたら言ってください。
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だったら○になります。
No.2
- 回答日時:
こんにちは
横からですが・・・
>制限させて調べる場合は、
>どのような記述になるでしょうか?
ご提示のsHtmlの代わりに、タイトルタグの内容だけの文字列を対象に、同様の処理を行えばよいのでは?
一応、変数を別にして
s = Mid(sHtml, InStr(sHtml, "<title>") + 7)
s = Left(s, InStr(s, "</title>") - 1)
などとしておけば、タイトルの内容が変数sに入りますので、後は、これを用いるようにすれば宜しいかと。。
タイトルタグの場合には、属性値が設定されている可能性は少ないので<title></title>決め打ちでも大抵の場合は大丈夫でしょうけれど、属性値が設定されていたり、タグ内にスペースが入っていたりすると、上記のような単純な検索ではうまくいかない可能性があります。
確実を期するなら、responseTextをhtml化(DOM化)して、getElementsByTagNameメソッドなどで抜き出すなどでしょうか。
以下のサイトのページ後半に記されている方法で可能かと思います。
No.1
- 回答日時:
nRtn = InStr(sHtml, "指定した語句")を
nRtn = InStr( Mid( sHtml, InStr(sHtml,"<title>") , InStr(sHtml,"</title>")-InStr(sHtml,"<title>") ),
"指定した語句")
とすれば、”<title>”から"</title>"までの文字列のなかで ”指定した語句” を検索することができます。
バグってたら教えてください。
回答ありがとうございます!
質問に、一つ書き忘れていました。
「指定した語句」の他にも、「指定した語句2」「指定した語句3」、
つまり、<title></title>の中に、「●●」「▲▲」「■■」のどれかが含まれていたら、
隣のセルに○を付ける。という風にしたいです。
ソース全体で調べるなら、
nRtn = InStr(sHtml, "●●") + InStr(sHtml, "▲▲") + InStr(sHtml, "■■")
で出来ると思うのですが、制限させて調べる場合は、
どのような記述になるでしょうか?
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
SDカードのルートパスを選択し...
-
Amazonで置き配指定しているの...
-
以前のメールを読みたい場合、...
-
佐川急便では、荷物が配達予定...
-
ヤマトの配達員がインターホン...
-
宅配便の伝票の貼り方
-
Amazonの配達員が不在票を入れ...
-
ヤマト運輸で配達時間を指定し...
-
ウーバーの配達員につまみ食い...
-
佐川急便に苦情を言いたい。 通...
-
宅配便 指定時間より早く届け...
-
メルカリ商品の受け取りは、配...
-
再配達依頼で時間指定したのに...
-
間違った不在連絡票はどうした...
-
バッテリを発送するにはどうし...
-
宅配便の誤配達について損害賠...
-
ウーバー配達員で満足度39%の人...
-
ドライバーからの着信について
-
「不在としております」は正し...
-
宅配便の依頼主が本人なのですが
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Amazonで置き配指定しているの...
-
タンスとか、冷蔵庫とか 上から...
-
日本郵便での荷物受け取り。 指...
-
【競馬】指定1頭ー指定4頭ー...
-
必着という言葉をどう取るか?
-
SDカードのルートパスを選択し...
-
神戸市中央区の燃えるゴミの袋...
-
makeの変数設定の優先度
-
QNo.を指定してのリンクの張り方
-
HP作成の際、文字コードに関す...
-
に 格助詞
-
あなたにおすすめ
-
.vimrcで細かいハイライト色の指定
-
本の郵送
-
最も多い 配達の指定時間帯
-
エクセル2016 IF、OR関数設定に...
-
簡易書留の事ですが日にち指定 ...
-
行を超えて範囲指定したい。
-
範囲指定
-
宅急便を利用する時に
おすすめ情報
みなさま、回答ありがとうございます!
実はこのマクロは、ネットで拾ったもので、
自分で書いたものではありません。
なので、Function~をどこに記述すればいいのか、から躓きます。
「●●」「▲▲」「■■」の複数の語句も、
どこに記述すればいいか分からず・・・。
一つ、マクロを書いていただけたら幸いです。
よろしくお願いいたします。