エクセルVBAにて同行内複数URLの抽出

質問

別枠で同系統の質問となってしまい申し訳ありません。
http://oshiete1.goo.ne.jp/qa5661746.html
上記でご教授頂いたサンプルを実行しましたところ
順調に動いていたのですが、
以下のように同じ行に複数の取得対象が存在するパターンになると
正常に取得できなくて困っています。

index.html内
<a href="http://www.test.co.jp">テスト１</a><img src="image.gif" alt="イメージ"></a><a href="http://www.test2.co.jp>テスト2</a>|<a href="http://www.test3.co.jp">テスト3</a>

このように、同じ行に複数の記述がされている際
最後の物のみ取得してしまい(http://www.test3.co.jpが取得される)
前の物全て取得できない状態です。

全てを取得するようにするにはどのようにすればいいか、
すみませんがよろしくお願いします。

なお、ファイルを読み込んでファイル内容を別シートに出力し、
そこから抽出している形を取っています。

回答No.3

mitarashi · ベストアンサー

http://okwave.jp/qa/q5651487.html
のコードをおためし下さい。
ハイパーリンクのURLは、match.submatches.Item(0)に取得できますので、
Debug.Print match.submatches.Item(0)
などと改造してみてください。Accessで回答していますが、Excelでも動くと思います。
ご呈示の1行のファイルで試験したところ拾い出せました。
ただし、href="http://www.test2.co.jp>テスト2　のところはダブルクォーテーションが一個欠落していて誤動作しましたので修正して試験しました。

お礼

申し訳ございません、動作しない部分を見直して行ったところ、
タイプミスが原因でした。
ペーストをしてしまうと形式すら身につかないと考え
手動で行っておりました。

試しましたところ、無事動作するようになりました。
お忙しいところありがとうございました。

補足

非常に言葉足らずで大変申し訳ございません。
前回の条件として
<a href="**">の**を取得したい、と記述したのは
【http://～】だけではなく
【/index.html】
などと言ったハイパーリンクではない物も取得したいからでした。
例文が悪く大変申し訳ございません。

回答No.4

mitarashi

#3です。パターンをご覧になりましたか？何処にもhttp://は出て来ません。下記のデータで問題なく取得できました。（自分の手柄ではなく、Microsoftの受け売りですが）
<a href="http://www.test.co.jp">テスト１</a><img src="image.gif" alt="イメージ"></a><a href="http://www.test2.co.jp">テスト2</a><a href="http://www.test3.co.jp">テスト4</a><a href="/test4.html">テスト4</a><a href="./test5/test5.html">テスト5</a>

お礼

申し訳ございません、動作しない部分を見直して行ったところ、
タイプミスが原因でした。
ペーストをしてしまうと形式すら身につかないと考え
手動で行っておりました。

試しましたところ、無事動作するようになりました。
お忙しいところありがとうございました。

回答No.2

DOUGLAS_

[回答番号：No.1] の DOUGLAS_ です。

＞取得した「テキスト(ソースコード)」をそのまま エクセル の ワークシート に貼り付け
るよりも、最初から、当該 WEBページ を エクセル に読み込む方が手間が省けますか。。。

Sub TEST()
　Dim HL As Hyperlink
　Dim myURL As Variant
　Dim i As Integer
　Dim j As Integer
　Workbooks.Open Filename:="http://oshiete1.goo.ne.jp/qa5661746.html"
　j = ActiveSheet.Hyperlinks.Count
　ReDim myURL(j - 1)
　For Each HL In ActiveSheet.Hyperlinks
　　myURL(i) = HL.Address
　　i = i + 1
　Next
　ActiveWorkbook.Close SaveChanges:=False
　Range("A1").Resize(j) = Application.WorksheetFunction.Transpose(myURL)
End Sub

お礼

お忙しい中ありがとうございました。
今後の参考にさせて頂きたいと思います。

補足

申し訳ありません、条件が抜けておりました。
ソースコードはローカルに配置してあります。

D:\test\ソース
配下に格納しています。

回答No.1

DOUGLAS_

＞別枠で同系統の質問
　リンク先は拝見いたしました。

＞マクロを用いてテキスト(ソースコード)よりURLを取得したい
とのことですが、「テキスト(ソースコード)」はどこに書いていらっしゃるのでしょうか？

＞全てを取得するようにするにはどのようにすればいいか
　結果オーライになりますが、取得した「テキスト(ソースコード)」をそのまま エクセル の ワークシート に貼り付けて、下記のコードを実行なさってみてください。

Sub TEST()
　Dim HL As Hyperlink
　Dim myURL As Variant
　Dim i As Integer
　Dim j As Integer
　j = ActiveSheet.Hyperlinks.Count
　ReDim myURL(j - 1)
　For Each HL In ActiveSheet.Hyperlinks
　　myURL(i) = HL.Address
　　i = i + 1
　Next
　Sheets.Add Type:="ワークシート"
　Range("A1").Resize(j) = Application.WorksheetFunction.Transpose(myURL)
　ActiveSheet.Next.Select
　Application.DisplayAlerts = False
　ActiveSheet.Delete
　Application.DisplayAlerts = True
End Sub