• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:サイトタイトルに、指定した語句があれば○)

サイトタイトルの指定語句を判断するマクロ

このQ&Aのポイント
  • マクロを使用して、指定範囲のURL先のソースに特定の語句があるかどうかを判断する方法を解説します。
  • 指定した語句をソース全体に対して検索するマクロから、<title></title>内のサイトタイトルの中にあるかどうかを判断するマクロへの修正方法について説明します。
  • 語句を指定する際に、カッコ「【】」を使用する方法も解説します。

質問者が選んだベストアンサー

  • ベストアンサー
  • kkkkkm
  • ベストアンサー率66% (1662/2518)
回答No.1

> 調べたいのは語句ではないですが、"【"というカッコです 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 に変更して試してみてください。

mute_low
質問者

補足

回答ありがとうございます! 早速、マクロを変更してやってみました。 すると、"【"があるのに、ちゃんと"○"が付くのと"--"になってしまうのがあります。 例えば、以下のURLは両方ともタイトルに"【"があります。 ですが、 https://kokuei-tcc.co.jp/ は、○が付きますが、 https://ihan.jp は、--になってしまいます。 "【"がある両方のURLに、○が付くようにできるでしょうか? よろしくお願いいたします。

全文を見る
すると、全ての回答が全文表示されます。

その他の回答 (3)

  • kkkkkm
  • ベストアンサー率66% (1662/2518)
回答No.4

> どういった記述を足すのでしょうか? HTMLの事についてはよくわかりませんので 元のコードの一部を以下に変更したものを記載して If sHtml Like "*<title>*" & "【" & "*</title>*" Then aCell.Offset(, 1).Value = "○" Else aCell.Offset(, 1).Value = "--" End If "【"がUTF-8のサイトだと認識できるのだが、Shift_JISのサイトでは認識できないのでどうすればいいか、という質問を新たに出してください。その際この質問は締め切ってください。

全文を見る
すると、全ての回答が全文表示されます。
  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.3

「どんなことを質問しているのか」と思って,微修正して、小生が簡単な例で数件やってみました。参考に。 #2のご指摘の点など考慮で来てませんが。 シート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

mute_low
質問者

補足

回答ありがとうございます。 調べたいURLが10万を越えており、 できるだけ早く調べていくマクロが必要と感じております。 サイトタイトルも取得できたら、ありがたいのですが、 タイトルに"【"が入っているか否か、これを調べていきたいです。 サイトによっては、文字コードがShift_JISのものがあるようで、 これを変換して調べて、10万URLの中から目的のものを取得したいです。 文字コードがShift_JISをUTF-8に変換して取得するには、 どのようなマクロの記述になりますでしょうか? よろしくお願いいたします。

全文を見る
すると、全ての回答が全文表示されます。
  • kkkkkm
  • ベストアンサー率66% (1662/2518)
回答No.2

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

mute_low
質問者

補足

返信ありがとうございます。 すみません。 こちらのマクロは、前に書いてもらったものであり、 私自身はマクロの知識がまったくない状態です。 >データを読み込んだ時にShift_JISをUTF-8に変換して操作 というのは、どういった記述を足すのでしょうか? よろしくお願いいたします。

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

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

    下記は、URL先のソースの中に、 指定した語句があれば、○を付けるマクロです。 このURL先のソース、全てを対象にするのではなく、 <title></title>、つまりサイトタイトルの中に、 指定した語句があれば、○を付けるというように制限して調べたいです。 ・下記のマクロ URL先のソース全体の中に、指定した語句があれば○ ・希望のマクロ <title></title>(サイトタイトル)の中に、指定した語句があれば○ これは、どの部分を修正、追加すればできるようになるでしょうか? また、「指定した語句」の他にも、「指定した語句2」「指定した語句3」、 つまり、<title></title>の中に、「●●」「▲▲」「■■」のどれかが含まれていたら、 隣のセルに○を付ける。という風にしたいです。 ソース全体で調べるなら、 nRtn = InStr(sHtml, "●●") + InStr(sHtml, "▲▲") + InStr(sHtml, "■■") で出来ると思うのですが、制限させて調べる場合は、 どのような記述になるでしょうか? よろしくお願いいたします。 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

  • "【"が、Shift_JISのサイトで認識できない

    下記のマクロは、指定範囲のURL先のソースに、 指定した語句があれば、○を付けるマクロです。 指定した語句をソース全て対象にせずに、 <title></title>のサイトタイトルの中に、"【"があれば○を付けるというようにしたいです。 (クォーテーションマーク抜きの【) https://okwave.jp/qa/q9899670.html こちらで先に質問をして回答をいただいたのが、 元のコードの一部を、 If sHtml Like "*<title>*" & "【" & "*</title>*" Then aCell.Offset(, 1).Value = "○" Else aCell.Offset(, 1).Value = "--" End If に変更するというものです。 しかし、これだとUTF-8のサイトは認識できますが、 Shift_JISのサイトでは認識できないようです。(【があるのに、○が付かない) UTF-8とShift_JISのサイト両方を認識して、 "【"が、<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

  • 「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

  • キーワードが全部あるのに、○が付かない

    下記のマクロは、URL先のソースの中に、 「赤ちゃん」「妊婦」「ママ」「水」「ウォーター」 のどれかがあれば、隣に○を付けるというものです。 ですが、 https://www.andrea-pennington.com/ こちらのサイトを調べたところ、 キーワードが全部あるのに、○が付かず--でした。 マクロの記述がどこかおかしいでしょうか? ソースの中に、どれかのキーワードがあれば、 ○が付くようにするには、どのような記述になるでしょうか? Excel2016です。 よろしくお願いいたします。 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 '選択セルの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, "赤ちゃん") + InStr(sHtml, "妊婦") + InStr(sHtml, "ママ") + InStr(sHtml, "水") + 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 は下記のようなマクロが入っています。 Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Error If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub If Target.Offset(0, -1).Value = "" Then Exit Sub If Target.Value <> "" Then Target.Offset(0, 1).Value = Application.Max(Range("C:C")) + 1 End If Error: End Sub 添付の下のように No 登録日 氏名 のように位置を変更は上のマクロのどの部分を 変更すればいいかご教示願えませんか。 宜しく御願いします。 色々と試したのですが分からなくなりました。

  • サイトタイトルを取得するマクロが「応答なし」になる

    下記のマクロは、選択したセルのURLからサイトタイトルを取得するものです。 このマクロを使って、1万を越えるURLの作業をやろうとしています。 作業に取り掛かったのですが、下記のマクロがすぐに「応答なし」になり、 エクセルの画面が真っ白になり、Escでマクロを止めることもできません。 ようやくマクロを止めても応答なしのときはマクロが動いておらず、作業が進みません。 取得するサイトタイトルの数が多いため、 寝てるときにマクロを動かしてやっていきたいです。 下記のマクロを「応答なし」にせずに、順調にサイトタイトルを取得していくには、 どのような記述にすれば、できるようになるでしょうか? EXCEL2016です。 よろしくお願いいたします。 ↓応答なしになるマクロ Sub サイトタイトル() Dim rng As Range Dim url As String Dim s As String For Each rng In Selection url = rng.Value If url <> "" Then If url Like "*://*" Then s = GetTitle(rng.Value) Else s = GetTitle("https://" & url) If s = "Error" Then s = GetTitle("http://" & url) If s = "Error" Then s = GetTitle("https://www." & url) If s = "Error" Then s = GetTitle("http://www." & url) End If rng.Offset(, 1) = s End If Next End Sub Function GetTitle(url As String) As String Dim http As Object Dim html As Object Set http = CreateObject("MSXML2.XMLHTTP") Set html = CreateObject("htmlfile") GetTitle = "Error" On Error Resume Next http.Open "GET", url, False http.send If http.Status <> 200 Then Exit Function On Error GoTo 0 html.Write http.responseText GetTitle = html.Title End Function

  • 列幅、行の高さを指定するマクロ

    元マクロ初心者(今はほとんど忘れています)です。 列幅、行の高さを変更するマクロを以前作りました。 セルに指定する列幅を入力するのですが、 最近100以上の値の時はスキップされることに気づきました。 100以上の値でも処理されるようにするにはどうすればよいでしょうか。 Sub 列幅変更マクロ() ' ' Macro1 Macro ' マクロ記録日 : 2004/1/31 ユーザー名 : ' 列幅の変更 ' Keyboard Shortcut: Ctrl+l ' If MsgBox("→:列幅を変更します。右の方向にセル内の数値に従って処理しています。一番右のセルに半角で「@」を終わりの印として入力してください。", vbOK) = 1 Then Do Until ActiveCell.Value = "@" If ActiveCell.Value < 100 Then If ActiveCell.Value > 0 Then Selection.ColumnWidth = ActiveCell.Value End If End If ActiveCell.Offset(0, 1).Select Loop End If End Sub Sub 行の高さ変更マクロ() ' ' Macro2 Macro ' マクロ記録日 : 2004/2/1 ユーザー名 : ' 行の高さ変更 ' Keyboard Shortcut: Ctrl+p ' If MsgBox("↓:行の高さを変更します。下の方向にセル内の数値に従って処理しています。一番下のセルに半角で「@」を終わりの印として入力してください。", vbOK) = 1 Then Do Until ActiveCell.Value = "@" If ActiveCell.Value < 100 Then If ActiveCell.Value > 0 Then Selection.RowHeight = ActiveCell.Value End If End If ActiveCell.Offset(1, 0).Select Loop End If End Sub

  • ASPをPHPに移植したいですが、よい方法があるでしょうか?

    ASPをPHPに移植したいですが、よい方法があるでしょうか? Set httpObj = Server.CreateObject("WinHttp.WinHttpRequest.5.1") If Err.Number <> 0 Then 'error check for http  Response.Write("エラー:" & Err.Description)  response.redirect("/ga-ko/error.asp?error=999")  response.end End If どうぞ、よろしくお願いします。

    • 締切済み
    • PHP
  • ExcelでのA1セルで名前と場所指定したい

    こんにちは、 エクセル2010 でマクロを色々勉強しながらやっているのですが、うまく行かず皆さん助けていただければと思います。 [概要] 1.Sheel1のA1セルをファイル名に。 2.保存場所を指定したフォルダ(会社サーバー内フォルダ) に保存したい こういうマクロを以下のように作ってみたのですが、名前を付けて保存するダイアログがしか表示されなく上手く行きません。 ご教授頂けたらと思います。 Sub TestFileSaveAs() '指定フォルダを置く Const MYPATH = "\\192.000.000.00\所属部\固定フォルダ\" Dim myData As String Dim myFile As String 'A1 にあるデータをファイル名にする If Range("A1").Value <> "" Then myData = Range("A1").Value End If On Error Resume Next Do Err.Clear myFile = Application.GetSaveAsFilename(MYPATH & myData, "EXCELファイル (*.xls), *.xls") If StrComp(myFile, "False") = 0 Then Exit Sub ActiveWorkbook.SaveAs myFile Loop While Err.Number > 0 End Sub

  • emptyが判定されない

    マクロの記述が巧くいかないので質問させてください。 以下のようなマクロを組んでみたのですが、うまくいきません。 sub a() If Range("K1").End(xlDown).Offset(0, 12).Value = "" Or Range("K1").End(xlDown).Offset(0, 12).Value = Empty Then Range("K1").End(xlDown).Offset(0, 12).Value = "必要ない" End If end sub マクロ画面上でRange("K1").End(xlDown).Offset(0, 12).Valueにポイントすると「Empty値」と出てくるため、= "" の後に=Emptyと入れてみたんですが、文字の入力がされません。 よろしくお願いします。

このQ&Aのポイント
  • USBメモリーに保存したデータを削除できず困っています。ご利用の端末タイプや製品名・型番など詳細を教えてください。
  • エレコム株式会社の製品についての質問です。USBメモリーに保存したデータが消去できず困っています。ご利用の製品や発生時期についてお知らせください。
  • USBメモリーにライトしたデータが削除できない問題について相談です。ご利用の端末タイプや製品名・発生時期など詳細情報をお教えください。
回答を見る