下記は、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で質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) いつもお世話になっております、VBAで教えて頂きたいのですが 2 2022/05/05 22:20
- Visual Basic(VBA) VBAでoutlook365が起動しません。 4 2022/08/25 13:31
- Visual Basic(VBA) オブジェクトが見つかりません 1 2023/06/24 19:43
- Visual Basic(VBA) VBAが止まります。 3 2022/08/31 14:09
- Excel(エクセル) VBAの指示の内容 昨日こちらでご教示頂いたのですが初心者な為、一つ一つの指示が何をやっているのかわ 2 2022/10/25 18:08
- Visual Basic(VBA) VBAの繰り返し処理について教えてください。 3 2022/08/02 13:21
- Visual Basic(VBA) excel2021で実行できないマクロ。どこを直したらいいのか 2 2022/03/28 03:40
- Visual Basic(VBA) Excel VBAの解読について質問があります。 概要は、マクロでチェックボックスにチェックすると日 1 2023/02/10 07:50
- Visual Basic(VBA) 稀に1円合いません? Sheet1から金額と個数を貼り付ける下記コードで、金額を切り上げるコードを何 3 2022/09/05 15:11
- Visual Basic(VBA) 別シートから年齢別の件数をカウントしたいの続き 5 2023/01/24 00:16
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
簡易書留の事ですが日にち指定 ...
-
ヤマト運輸からくる荷物全てを...
-
タンスとか、冷蔵庫とか 上から...
-
レポートの概要てどのくらいの...
-
ヤフーショッピングでメール便...
-
太平洋フェリーの寝台等級のベ...
-
必着という言葉をどう取るか?
-
アクセスIfブロックに対応するE...
-
ヤマトでクール便を時間指定2回...
-
宅配業者は印鑑求めてきますか...
-
宅配便の伝票の貼り方
-
宅配便の依頼主が本人なのですが
-
「不在としております」は正し...
-
レターパックライトが戻ってき...
-
配達員は来ているけど不在票が...
-
佐川急便では、荷物が配達予定...
-
「不在」の反対語を教えてください
-
バッテリを発送するにはどうし...
-
配達員さんの事が気になってい...
-
ヤマト運輸の本社にクレームの...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
タンスとか、冷蔵庫とか 上から...
-
ヤマト運輸からくる荷物全てを...
-
SDカードのルートパスを選択し...
-
簡易書留の事ですが日にち指定 ...
-
エクセルで最大公約数を求めた...
-
数式を教えてください!!! 0...
-
運送会社が時間指定配達をして...
-
ネットショップを運営していま...
-
個人の敷地を町道に指定して無...
-
ゆうパックの配達日指定
-
必着という言葉をどう取るか?
-
遠音別岳原生自然環境保全地域...
-
いつもお世話になります。
-
エクセル VBAで文章にある複数...
-
晴空塔
-
指定可燃物
-
太平洋フェリーの寝台等級のベ...
-
まんだらけ通販の時間指定は本...
-
宅配便の伝票の貼り方
-
佐川急便では、荷物が配達予定...
おすすめ情報
みなさま、回答ありがとうございます!
実はこのマクロは、ネットで拾ったもので、
自分で書いたものではありません。
なので、Function~をどこに記述すればいいのか、から躓きます。
「●●」「▲▲」「■■」の複数の語句も、
どこに記述すればいいか分からず・・・。
一つ、マクロを書いていただけたら幸いです。
よろしくお願いいたします。