- 締切済み
URLからタイトルを取得したい！
エクセルのＡ列にはURLがずらっとあり、Ｂ列にタイトル取得を考えています。 そこで、他の質問者さんのコードを試しました。 その結果、普通のサイトでは問題なく取得できたのですが、 アメーバーブログなどの無料ブログでは、途中で止まってエラーとなってしまうようです。 どこかいけないのでしょうか？ Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A1") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function
- siraku
- お礼率54% (276/508)
- Visual Basic
- 回答数1
- ありがとう数0
- みんなの回答 （1）
- 専門家の回答
みんなの回答
- todo36
- ベストアンサー率58% (728/1234)
アメブロはUTF-8なので buf = StrConv(Http.ResponseBody, vbUnicode) が駄目。 解決策 http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1130785456
関連するQ&A
- エクセルでURLからタイトルのみを抽出する方法
URLからタイトルを抽出するマクロについて教えて下さい。 忍者ブログの記事タイトルをURLから抽出しようとしたのですが 文字化けしてしまい全く分かりません。 他のサイトやブログだと普通に抽出出来るのですが・・・ 文字コード？か何かだと思うのですが、原因が分かりません。 ちなみに以下のマクロは、ネット上で検索して見つけたものを そのままコピーして使用しています。 －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A3") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ 宜しくお願い致します。
- ベストアンサー
- Visual Basic
- エクセルでマクロの進行状況を表示あるには
下記のマクロはURLからタイトルを抽出するものなのですが 件数が何千件とあり、進行状況が分かれば便利かなと思います。 表示方法はどのような形でも構わないのですが、ご教授願います。 色々調べたのですがうまくいかず困っております。 ちなみに私は全くの度素人であり、マクロもネット上で検索して 見つけたものをそのまま使用しております。 －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Private Sub CommandButton1_Click() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A2") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send With CreateObject("ADODB.Stream") .Open .Type = 2 'adTypeText .Charset = "unicode" .Writetext Http.ResponseBody .Position = 0 .Charset = "utf-8" buf = .ReadText() .Close End With 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function Private Sub タイトル抽出_Click() End Sub －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ 宜しくお願い致します。
- ベストアンサー
- Visual Basic
- エクセルでメタタグを抽出するには？
すいません、前回質問した者です。 前回の質問では・・・ エクセルシートのB列にURLが並んでいるとして、ＶＢＡを使って、C列には「description」D列には「keywords」を抽出したいという質問をしたのですが、参考になる回答がなかったのでもう一度質問します。 以前、私が教えてもらったのは、B列にURLが並んでいて、Ａ列にタイトルを抽出させたものでした。 それが以下になります。 Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("B1") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, -1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function このような感じでＢ列にはURLの一覧があるとして、Ａ列にタイトル、C列にdescription D列にkeywordsが抽出できればいいなと考えています。 ちなみに、私にはＶＢＡの知識がまったくありません。とりあず、これだけ出来れば、すごく助かるのですが、どなたか教えていただけないでしょうか？ よろしくお願いします！
- ベストアンサー
- Visual Basic
- サイトタイトルを取得するマクロが「応答なし」になる
下記のマクロは、選択したセルのURLからサイトタイトルを取得するものです。 このマクロを使って、１万を越える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
- ベストアンサー
- Visual Basic
- エクセルファイル 行列入れ替えたもの同時作成VBA
あるxmlファイルを一旦テキストファイルにして そこから数値をエクセルファイルに移行して ひとつはM.xlsxとし それに続いて行列を入れ替えた エクセルファイルR.xlsxを 作りたいのですが M.xlsx R.xlsxのそれぞれを作るコードを 単純に 合体させただけでは どうも できません M.xlsxだけ また R.xlsxだけの 作成するコードは 出来たのですが それぞれ別のマクロとして実行することになります ひとつのマクロでM.xlsx R.xlsx同時に 作成するVBAコードは可能でしょうか 宜しくお願い致します ちなみに該当コードを単純化して 合体したのが以下のものです win10 office10 Sub 783縦() Dim FileName As Variant ChDir "\\DESKTOP-O5\f" FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml") If FileName = False Then MsgBox "キャンセルされました" Exit Sub End If FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt" Const MyFile = "\\DESKTOP-O5\f\テキスト.txt" Const Key1 = "<Name>" Const Key2 = "</Name>" Const Key3 = "<NameKana>" Const Key4 = "</NameKana>" Const PutBokName = "M.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(2, 1).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With Const PutBokName = "R.xlsx" Dim buf As String Dim Len1 As Long Dim Len2 As Long Dim Pos1 As Long Dim Pos2 As Long Dim Len3 As Long Dim Len4 As Long Dim Pos3 As Long Dim Pos4 As Long Dim PutBook As Workbook With CreateObject("ADODB.Stream") .Charset = "UTF-8" .Open .LoadFromFile MyFile buf = .ReadText .Close End With Len1 = Len(Key1) Len2 = Len(Key2) Pos1 = InStr(buf, Key1) Pos2 = InStr(buf, Key2) Len3 = Len(Key3) Len4 = Len(Key4) Pos3 = InStr(buf, Key3) Pos4 = InStr(buf, Key4) Set PutBook = Workbooks.Add With PutBook.Sheets(1) .Cells(1, 1).Value = "氏名" .Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1)) .Cells(1, 2).Value = "氏名カナ" .Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3)) 'クリップボードをクリア Application.CutCopyMode = False PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName End With End Sub -------------------------------
- 締切済み
- その他（プログラミング・開発）
- VBAでソースから全てのURLを取得したい
VBAでソースに書いてある全てのURLを取得したいのですが、現状では一部しか取得できません。 文字数制限にでも引っかかっているのでしょうか？ どうすれば全てのURLを取得できるのか・・添削して頂けると or ヒントを教えて頂けると助かります。 よろしくお願いします。 (Excel2003を使用) Sub test() Dim objIE As Object Dim objTAG As Object Dim source As String Dim url As String Dim url_start As String Dim url_end As String Dim y As Long url_end = 1 y = 1 Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = False objIE.Navigate "http://dir.yahoo.co.jp/" Do While objIE.Busy = True DoEvents Loop Application.Wait Time:=Now + TimeValue("00:00:03") source = objIE.Document.All(1).Innerhtml Do While y < 10000 url_start = InStr(url_end, source, "<a href=", vbTextCompare) If url_start = 0 Then y = 10000 Else url_end = InStr(url_start, source, ">", vbTextCompare) url = Mid(source, url_start + 9, url_end - url_start - 10) Cells(y, 1).Value = url y = y + 1 End If Loop End Sub
- ベストアンサー
- Visual Basic
- 縦に取得するのを横にする＆最後に取得したところから
下記のマクロで、A1の語句をGoogle検索して、 上位５位のタイトル・URLをA2～A11へ記入できます。 そのA1に語句、A2～A11に上位５位というのを、 A1に語句、B1～K1に上位５位という風に変更したいです。 A1（語句）｜A2（タイトル）｜A3（URL）｜ ↓ A1（語句）｜B1（タイトル）｜C1（URL）｜ という感じです。 もう一つ、 途中でロボットでない証明のクリックがあります。 そのため、マクロを止めざるおえないです。 改めて、マクロを再開する時に、 最後に取得した語句から始めるようにしたいです。 これらは、どのようなマクロの記述になるでしょうか？ EXCEL２０１６です。 よろしくお願いいたします。 '//標準モジュール Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) Dim objIE As SHDocVw.InternetExplorer '参照設定 Microsoft Internet Contorls Dim oHTML As HTMLDocument '参照設定 Microsoft HTML Object Library Sub Main() Dim c As Range Dim enSrTxt As String Dim counter As Long On Error GoTo ErrHandler Const BASEURL As String = "https://www.google.co.jp/search?q=" With ActiveSheet Set objIE = Nothing For Each c In .Range("A1", .Cells(1, Columns.Count).End(xlToLeft)) If c.Value <> "" Then If c.Value Like "*[ぁ-龠]*" Then enSrTxt = EnUtf8(c.Value) Else enSrTxt = c.Value End If Call getIE(BASEURL & enSrTxt) 'Application.Wait TimeSerial(0, 0, 10) '遅くしていた元凶 Sleep 500 counter = counter + 1 End If Next c End With ErrHandler: If Err <> 0 Then MsgBox Err.Description End If End Sub Sub getIE(ByVal strURL As String) Dim cnt As Long Dim cl As Object Dim c As Range Dim nm As Long Set oHTML = New HTMLDocument If objIE Is Nothing Then Set objIE = New SHDocVw.InternetExplorer End If Set c = Cells(2, Columns.Count).End(xlToLeft) '二行目で計る If c.Value <> "" Then nm = c.Column + 1 Else nm = c.Column With objIE .Visible = True .navigate strURL Do While .Busy Or .readyState <> 4: DoEvents: Loop Set oHTML = .document End With Call outputLog(oHTML, nm) Set cl = objIE.document.getElementsByClassName("csb ch") cl(1).Click DoEvents Sleep 500 Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop Set oHTML = objIE.document Cells(1, nm).EntireColumn.AutoFit Application.ScreenUpdating = True End Sub Sub outputLog(oHTML As HTMLDocument, nm As Long) Dim buf As Variant Dim j As Long, i As Long, k As Long Dim gLinks As Object Dim mTitle As Variant Dim cnt As Long j = Cells(Rows.Count, nm).End(xlUp).Row + 1 With oHTML Set mTitle = oHTML.getElementsByClassName("LC20lb") Set gLinks = oHTML.getElementsByClassName("TbwUpd") If gLinks.Length > 0 Then If (gLinks.Length - 1) > 4 Then cnt = 4 Else cnt = gLinks.Length - 1 For i = 0 To cnt '' 5コまで、 Cells(j, nm).Value = mTitle(i).innerText buf = gLinks(i).ParentNode.href If InStr(1, buf, "%") > k Then buf = DecodeUTF8(buf) Cells(j + 1, nm).Value = buf Cells(j + 1, nm).Font.ColorIndex = 4 'フォントの色 j = j + 2 buf = "" Next End If End With End Sub Private Function EnUtf8(ByRef strSource As String) As String 'Encode Dim objSC As Object Set objSC = CreateObject("ScriptControl") objSC.Language = "Jscript" EnUtf8 = objSC.CodeObject.encodeURIComponent(strSource) Set objSC = Nothing End Function Private Function DecodeUTF8(ByVal strSearch As String) 'Decord If strSearch = "" Then Exit Function With CreateObject("ScriptControl") .Language = "JScript" With .CodeObject DecodeUTF8 = .decodeURI(strSearch) End With End With End Function
- 締切済み
- Excel（エクセル）
- グーグルに登録されているかをチェックする場合
エクセルのE列にURLがあるとします。（数は500～1000ぐらい） F列には、Ｅ列にあるURLをグーグルで検索し、検索結果がある場合は、「○」ない場合は「×」で判定します。 G列には、グーグルで検索結果の約○○件、あるいは○件、これら○に入る数字を取得したいです。 そこで、以前、同じことを教えてもらったのですが、グーグルの使用が変更になったせいかすべて検索結果が「×」判定となってしまいました。 そのコードが下記なのですが、どこを修正すればいいのか教えてください。 よろしくお願いします。 '標準モジュール Private Const SKEY As String = "http://www.google.co.jp/search?hl=ja&q=" Public Sub GoogleCheckers() Dim c As Range Dim buf As String Const qt As String = "" With ThisWorkbook.Sheets("登録チェック") For Each c In Range("E6", Cells(Rows.Count, 5).End(xlUp)) If c.Value <> "" Then Application.ScreenUpdating = False buf = UrlEncode(c.Value) buf = SKEY & buf ItemCehck buf, c Application.ScreenUpdating = True End If Next End With End Sub Private Sub ItemCehck(ByVal strURL As String, iRng As Range) Dim rng As Range Dim objHTTP As Object Dim i As Long, j As Long Dim c As Variant Dim httpLog As String Dim msgbuf As Variant Dim LimitNum As Long On Error GoTo ErrHandler Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1") objHTTP.Open "GET", strURL, False objHTTP.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-JA; rv:1.9.2.12)" objHTTP.Send If Err.Number = 0 Then If objHTTP.Status = 200 Then httpLog = objHTTP.ResponseText Call ContentsCheck(httpLog, iRng) ElseIf objHTTP.Status >= 400 Then iRng.Offset(, 1).Value = "アクセスエラー" End If Else iRng.Offset(, 1).Value = "?" End If Exit Sub ErrHandler: iRng.Offset(, 1).Value = "不明" End Sub Private Sub ContentsCheck(httpLog As String, rng As Range) 'rev:101226 Dim i As Long, j As Long Dim buf As Variant Const STXT As String = "検索オプション</a></div><div><div id=resultStats>" i = InStr(1, httpLog, STXT, 1) If i > 0 Then buf = Mid(httpLog, i + Len(STXT), 50) j = InStr(1, buf, "件<nobr>", 1) buf = Mid(buf, 1, j) buf = Replace(buf, "約", "") buf = Replace(buf, "件", "") End If If CLng(Val(buf)) > 0 Then rng.Offset(, 1).Value = "○" rng.Offset(, 2).Value = buf Else rng.Offset(, 1).Value = "×" End If End Sub Private Function UrlEncode(ByVal sText As String) As String Dim buf As String If Len(sText) = 0 Then Exit Function With CreateObject("ScriptControl") .Language = "JScript" buf = .CodeObject.encodeURI(sText) buf = Replace(buf, ":", "%3A", , , 1) buf = Replace(buf, "/", "%2F", , , 1) UrlEncode = buf End With End Function
- ベストアンサー
- Visual Basic
- VBAで文字の位置が正確に取得できない
Excel2003のマクロで、URLを抜き出すマクロを作っているのですが、なぜかurl_endの値が正確に取得できません。何がいけないのでしょうか？ 事象 url_endに格納される値がなぜか1376(くらいだったような・・)になってしまう。 url_startには1260が格納されており、<a href=の部分をきちんと取得している。 ソース Sub test() Dim objIE As Object Dim objTAG As Object Dim souce As String Dim url As String Dim url_start As String Dim url_end As String url_end = 1 Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = False objIE.Navigate "http://dir.yahoo.co.jp/" Do While objIE.Busy = True DoEvents Loop Application.Wait Time:=Now + TimeValue("00:00:02") url_start = InStr(url_end, objIE.Document.All(1).Innerhtml,"<a href=", vbTextCompare) url_end = InStr(url_start,objIE.Document.All(1).Innerhtml, ">", vbTextCompare) url = Mid(objIE.Document.All(1).Innerhtml, url_start, url_end) Cells(1, 1).Value = url End Sub
- ベストアンサー
- Visual Basic
- このマクロの説明をお願いします
Dim buf As String Private Sub CommandButton1_Click() End Sub Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim tmp As Variant Application.EnableEvents = False tmp = InStr(2, buf, "$", vbTextCompare) tmp = Right(buf, Len(buf) - tmp) If buf = "$B$" & tmp Then Range("C" & tmp).Value = Range("C" & tmp).Value + Range("B" & tmp).Value Range(buf).Select End If Application.EnableEvents = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) buf = ActiveCell.Address End Sub どうやらB列の各セルに入力がされた場合、隣接するC列のセルに加算していくマクロのようです。 なんですが、 InStr関数、Right関数、Len関数あたりでやっていることがよくわかりません。 Private Sub CommandButton1_Click()は必要なのでしょうか？ あと、 もっとシンプルなマクロができるようでしたらご教授ねがいます。
- 締切済み
- Visual Basic
補足
回答ありがとうございます。 今、試してみたのですが、どうも自分では、上手くできません。 申し訳ないのですが、具体的にコードを書いていただけないでしょうか？ よろしくお願いします。