エクセルVBAにてURLの抽出

質問

エクセルVBAのマクロを用いてテキスト(ソースコード)よりURLを取得したいと考えています。
<a href="**">　左記の「**」を取得し、エクセル上に
一覧として出力するものを想定しています。
なお、ソース上にhrefのコードは複数存在するので、
それら全てを出力したいのです。
以下が出力希望例になります。
<a href="http://www.test.co.jp">
<script type="text/javascript">
<a href="http://www.test2.co.jp">
出力結果
http://www.test.co.jp
http://www.test2.co.jp

諸事情があり、テキストを読み込んでエクセル上に取得する形式でお願いしたいです。

すみませんが、よろしくお願いします。

回答No.1

nda23 · ベストアンサー

正規表現を使って、一致する部分を収集します。
Function GetURL(ByVal HTML As String) As Variant
Dim 正規表現
Dim 一致集合_href用
Dim 一致要素_href用
Dim 一致集合_引用符
Dim 一致要素_引用符
Dim 部分列 As String
Dim 引用符 As String
Dim 位置 As Long
Dim 要素数 As Long
ReDim URL(0) As String

要素数 = -1
Set 正規表現 = CreateObject("VBScript.RegExp")
正規表現.Global = True
正規表現.IgnoreCase = True
正規表現.Pattern = "<.*\s+href\s*=\s*"
Set 一致集合_href用 = 正規表現.Execute(HTML)
正規表現.Global = False
For Each 一致要素_href用 In 一致集合_href用
　　　　位置 = 一致要素_href用.FirstIndex + 一致要素_href用.Length
　　　　部分列 = Mid(HTML, 位置 + 1)
　　　　引用符 = Left(部分列, 1)
　　　　Select Case 引用符
　　　　　　　　Case """"
　　　　　　　　　　　　正規表現.Pattern = "\"""
　　　　　　　　　　　　部分列 = Mid(部分列, 2)
　　　　　　　　Case "'"
　　　　　　　　　　　　正規表現.Pattern = "'"
　　　　　　　　　　　　部分列 = Mid(部分列, 2)
　　　　　　　　Case Else
　　　　　　　　　　　　正規表現.Pattern = "[\s>]"
　　　　End Select
　　　　Set 一致集合_引用符 = 正規表現.Execute(部分列)
　　　　For Each 一致要素_引用符 In 一致集合_引用符
　　　　　　　　要素数 = 要素数 + 1
　　　　　　　　ReDim Preserve URL(要素数)
　　　　　　　　URL(要素数) = Left(部分列, 一致要素_引用符.FirstIndex)
　　　　　　　　Exit For
　　　　Next
Next
If 要素数 >= 0 Then GetURL = URL
End Function

呼び出しサンプル
Dim T$, A, B, C&
T = "<a href = ""http://www.test.co.jp"">" & vbNewLine _
　& "<script type=""text/javascript"">" & vbNewLine _
　& "<a href='http://www.test2.co.jp'>" & vbNewLine _
　& "<script type=""text/javascript"">" & vbNewLine _
　& "<a href= http://www.test3.co.jp >"
A = GetURL(T)
If IsEmpty(A) Then
　　MsgBox ("URLなし")
Else
　　For Each B In A
　　　　C = C + 1
　　　　Cells(C, 1) = B
　　Next
End If

正規表現オブジェクト、構文については以下を参照
http://msdn.microsoft.com/ja-jp/library/cc392403.aspx
http://msdn.microsoft.com/ja-jp/library/cc392020.aspx

お礼

丁寧な回答ありがとうございます。
非常に助かりました。