VBAでソースから全てのURLを取得する方法

前へ 次へ
このQ&Aのポイント
  • VBAを使用して、ウェブページのソースから全てのURLを取得する方法について教えてください。
  • 現在の状況では一部のURLしか取得できていないため、全てのURLを取得する方法を知りたいです。
  • Excel2003を使用しており、文字数制限に引っかかっている可能性もあるかもしれません。どのようにしたら全てのURLを取得できるのか、ヒントを教えてください。
回答を見る
  • ベストアンサー

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

  • j-y-a
  • お礼率28% (56/197)

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

  • ベストアンサー
回答No.2

> objIE.Document.All(1).Innerhtml ではなく aタグのみを列挙して、ちゃんと属性を取得したほうが確実ではないでしょうか？ documentのlinksコレクションからanchorオブジェクトを取得し、hrefプロパティの値を取得すればいいです。 参考 http://www.ken3.org/backno/backno_vba15.html#71

j-y-a
質問者

お礼

素晴らしい・・・ 完璧でした。 ありがとうございました。

その他の回答 (1)

  • miyuyu
  • ベストアンサー率61% (30/49)
回答No.1

こんばんは 当方もExcel2003で実行してみました https://login.yahoo.co.jp/config/login?.src=dir&lg=jp&.intl=jp&.done=http%3A%2F%2Fdir.yahoo.co.jp%2F http://www.yahoo.co.jp/ http://bb.yahoo.co.jp/ http://my.yahoo.co.jp/ http://help.yahoo.co.jp/help/jp/dir/ http://bookmarks.yahoo.co.jp/action/bookmark?t="+encodeURIComponent(document.title)+"&u="+encodeURIComponent("http://dir.yahoo.co.jp/")+"&fr=ybm_dir http://bookmarks.yahoo.co.jp/action/bookmark?t=Yahoo!%20JAPAN%E3%81%AE%E3%83%87%E3%82%A3%E3%83%AC%E3%82%AF%E3%83%88%E3%83%AA%E6%A4%9C%E7%B4%A2%20-%20Yahoo!%E3%82%AB%E3%83%86%E3%82%B4%E3%83%AA&u=http%3A%2F%2Fdir.yahoo.co.jp%2F&fr=ybm_dir http://bookmarks.yahoo.co.jp/url?url="+encodeURIComponent("http://dir.yahoo.co.jp/")+" http://bookmarks.yahoo.co.jp/url?url=http%3A%2F%2Fdir.yahoo.co.jp%2F http://ameblo.jp/mikako-ryoma/entry-10190485890.html http://www.kentei-uketsuke.com/ryoma.html http://dir.yahoo.co.jp/pg/mycategory/ が、吐き出されますが どのように出力されれば正解なんですか その辺教えてください

j-y-a
質問者

補足

http://dir.yahoo.co.jp/に記載されている全てのURLが出力されれば正解です。 よろしくお願いします。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • 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

  • ＶＢＡでソースの一番上から取得するには？

    Sub 取得() Dim objIE As Object Set objIE = CreateObject("InternetExplorer.Application") objIE.Navigate "http://www.google.co.jp/" objIE.Visible = True Do While objIE.Busy = True DoEvents Loop Debug.Print objIE.Document.body.innerHTML Set objIE = Nothing End Sub これだと、 <DIVstyle="DISPLAY:none"id=cst></DIV><TEXTAREAstyle="DISPLAY:none" id=csi></TEXTAREA><SCRIPT>if(google.j.b)document.body.style.visibility='hidden';</SCRIPT> からしか取得されないのですが、 実際のソースを見ると <!doctype html><html itemscope="itemscope" itemtype="http://schema.org/WebPage"> で始まってます。 ＶＢＡソースのてっぺんから取得する方法を教えてください。 innerHTML以外を使うのでしょうか？

  • 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

  • MSXML2で、サイトのタイトルを取得したい

    アクセスｖｂａです。 InternetExplorerの方法だと、 **************************************************** Sub Sample1() Dim ObjIE As InternetExplorer Set ObjIE = CreateObject("InternetExplorer.Application") ObjIE.Navigate "http://www.yahoo.co.jp/" ObjIE.Visible = True Do While ObjIE.Busy = True DoEvents Loop Do While ObjIE.Document.ReadyState <> "complete" DoEvents Loop Debug.Print ObjIE.Document.Title Debug.Print ObjIE.LocationName ' 同じ ObjIE.Quit Set ObjIE = Nothing End Sub **************************************************** で、該当のサイトのタイトルを取得できるのですが、 これではなく、 **************************************************** Sub Sample2() Dim objMSXML2 As Object Dim myObj As Object Dim myAll As Variant Set objMSXML2 = CreateObject("MSXML2.XMLHTTP") objMSXML2.Open "GET", "http://www.yahoo.co.jp/", False objMSXML2.Send myAll = objMSXML2.responseText 'ソースを抜き出す ’タイトル取得 Set objMSXML2 = Nothing End Sub **************************************************** の方法で、サイトのタイトルを取得したいのですが、 可能でしょうか？ コードをご教授ください。よろしくお願いします。

  • VBA　InStrがうまくできない

    ソースを見ると <div class="hd"> と言うタグは有るのに VBAで Sub test() Dim objIE As Object Dim myObj As Object Dim str電話番号 As String Dim strHTML As Variant Dim intstart As Variant str電話番号 = "03-58**-58**" Set objIE = CreateObject("MSXML2.XMLHTTP") objIE.Open "GET", "http://search.loco.yahoo.co.jp/search?p=" & str電話番号, False objIE.send strHTML = objIE.responseText intstart = InStr(1, strHTML, "<div class=""hd"">") End Sub とした時にintstartは0が返ります。 なぜソース上は<div class="hd">は存在するのに 0が返るのでしょうか?

  • VBA IE制御 TABLE取得できません

    以下のコードを使用し、WEBページから「レース検索結果」のテーブルを取得しようとしました。 エラーは出ないのですがコード下から５行目で「OK」のメッセージボックスが 表示されるはずなのですが表示されませんでした。 ローカルウィンドウで確認したところ、summary「レース検索結果」が取得できていませんでした。 WEBページのソースには「レース検索結果」というsummaryは存在しているんですが・・・ どなたかご教授ねがいます OS:Windows 7 Excel:2007 InternetExplorer:11 Sub test() Const strURL As String = "http://db.netkeiba.com/?pid=race_search_detail" Dim objIE As New InternetExplorer Dim objDoc As HTMLDocument Dim objAllInput As Object Dim objInput As HTMLInputButtonElement Dim objAllTable As Object Dim objTable As HTMLTable With objIE .navigate strURL .Visible = True End With Do While objIE.Busy = True Or objIE.readyState <> 4 DoEvents Loop Set objDoc = objIE.document Set objAllInput = objDoc.getElementsByTagName("input") For Each objInput In objAllInput If objInput.ID = "check_Jyo_09" Then objInput.Checked = True Exit For End If Next Do While objIE.Busy = True Or objIE.readyState <> 4 DoEvents Loop For Each objInput In objAllInput If objInput.Value = "検索" Then objInput.Click Exit For End If Next Do While objIE.Busy = True Or objIE.readyState <> 4 DoEvents Loop Application.Wait (Now + TimeValue("00:00:10")) Set objDoc = objIE.document Set objAllTable = objDoc.getElementsByTagName("table") For Each objTable In objAllTable If objTable.Summary = "レース検索結果" Then MsgBox "OK" Exit For End If Next End Sub

  • サイトのソースのsubmitボタンの数を取得したい

    サイトのソースのsubmitボタンの数を取得したいのですが Sub test() Dim objIE As InternetExplorer Dim MyRow As Long Set objIE = CreateObject("InternetExplorer.Application") objIE.Visible = True objIE.Navigate "http://www.coneco.net/" Do While objIE.Busy = True Or objIE.ReadyState <> 4 DoEvents Loop Debug.Print objIE.Document.all.tags("input").Type("submit").Count Set objIE = Nothing End Sub だとうまく動きません。 どう、変更すればよろしいですか？

  • 「オブジェクトの破棄」と「メモリの解放」は同じ意味

    「オブジェクトの破棄」と「メモリの解放」は同じ意味ですか？ ********************************* Sub Sample1() Dim objIE As Object Dim buf As String Set objIE = CreateObject("InternetExplorer.Application") objIE.Visible = True objIE.navigate "http://oshiete.goo.ne.jp/" Do While objIE.busy DoEvents Loop Do While objIE.Document.readyState <> "complete" DoEvents Loop Set objIE = Nothing End Sub ********************************* の場合の「Set objIE = Nothing」は、 「オブジェクトの破棄」でしょうか？ 「メモリの解放」でしょうか？ どちらでもありますか？ ご回答よろしくお願いします。

  • 【VBA】IEのリンクを新しいタブで開く

    VBAでIEを制御しリンク（アンカー）<a href="***">を新しいタブで開くようにしたいのですが可能でしょうか？ 仮にグーグルのトップページ(http://www.google.co.jp/)の『検索オプション』(http://www.google.co.jp/advanced_search?hl=ja)を新しいタブで開くとします 実際に開きたいリンクのURLは固定ではないためURLの指定では開けませんが、飛びたいリンクの文言（『検索オプション』）は固定です リンクに飛ぶ前に飛ぶ先のURLを取得する仕方か、Shift+Ctrl+クリックのようにリンクを新しいタブで開く方法を教えてください 一度普通にリンクに飛んでからURLを取得し、戻ってから新しいタブで開くぐらいしかできないのでしょうか？ Sub 新しいタブで開く() Dim objIE As Object Dim objShell Dim URL As String Set objShell = CreateObject("Shell.Application") For n = objShell.Windows.Count To 1 Step -1 Set objIE = objShell.Windows(n - 1) If Right(UCase(objIE.FullName), 12) = "IEXPLORE.EXE" Then objIE.Navigate "http://www.google.co.jp/" Exit For End If Next Set objShell = Nothing objIE.Visible = True Do While objIE.Busy = True Or objIE.ReadyState <> 4 DoEvents Loop For Each Obj In objIE.Document.getElementsByTagName("a") If Obj.innerText = "検索オプション" Then Obj.Click Do While objIE.Busy = True Or objIE.ReadyState <> 4 DoEvents Loop URL = objIE.Document.URL objIE.GoBack Do While objIE.Busy = True Or objIE.ReadyState <> 4 DoEvents Loop objIE.Navigate URL, CLng(&H800) Exit For End If Next End Sub よろしくお願いいたします

  • EXCEL VBAで　URLの内容　が取得できない

    EXCEL VBA で　VBAサンプルを参考にして、下記により、URLの内容を得ようとしていますが、できません。　どうも、URL画面の中に　インプット用の記述があると、できなくなるのでは、と推測していますが、できるケースもあるようです。解決方法があるようでしたら、教えていただけますでしょうか？ (Win7 64B EXCEL2010 IE11です。)' Sub URL取得TEST() On Error GoTo Er1 Dim StrUrl As String StrUrl = InputBox("URLを指定", "URL入力", "http://www3.nhk.or.jp/nhkworld/") ' これは　読み込めます StrUrl = InputBox("URLを指定", "URL入力", "http://uwl.weblio.jp/") ' これが読み込めません Dim objIE As Object Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = True objIE.FullScreen = False objIE.Top = 200 objIE.Left = 100 objIE.Width = 800 objIE.Height = 600 objIE.navigate StrUrl While (objIE.readyState <> 3 And objIE.readyState <> 4) Or objIE.busy = True DoEvents Wend DoEvents Workbooks.Add objIE.ExecWB 17, 0 objIE.ExecWB 12, 0 Sheets.Add ActiveSheet.name = "Format テキスト" Range("A1").Select ActiveSheet.PasteSpecial Format:="テキスト" objIE.ExecWB 17, 0 objIE.ExecWB 12, 0 Sheets.Add ActiveSheet.name = "FormatHTML" Range("A1").Select ActiveSheet.PasteSpecial Format:="HTML" '別のURLでテキストOKでこれはだめというケースあり ' objIE.Quit Set objIE = Nothing Exit Sub ' Er1: objIE.Quit Set objIE = Nothing End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する