【Excelマクロ】URL一覧からMETA情報を抽出してB列～に書き出す

Tumblrに掲載してて、ちょくちょくアクセスがあったので、こっちにも掲載してみました。
仕事してて、こんなのあったら便利だなーと思って作ったマクロです。

A列の各URLから、META情報を抽出して、B～S列に各パラメーターを出力してくれます。
※A1セルから順にURLを入力していってください。A1セルから入力しないと、このマクロ動きません(笑)

• A列：URL
• B列：title
• C列：description
• D列：keyword
• E列：H1
• F列：author
• G列：robots
• H列：copyright
• I列：og:title
• J列：og:description
• K列：og:image
• L列：og:url
• M列：og:type
• N列：og:site_name
• O列：fb:admin
• P列：twitter:account_id
• Q列：twitter:card
• R列：twitter:site
• S列：twitter:image:src

Public Sub ReadTitle()
Dim url As Range
Dim Http, buf As String
Dim re, mc
Set Http = CreateObject("MSXML2.XMLHTTP")
Set re = CreateObject("VBScript.RegExp")

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

With re
.IgnoreCase = True
.Global = True

'title、description、keywords、H1を取得して出力
.Pattern = "<title>(.*?)</title>"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 1) = mc(0).SubMatches(0)

.Pattern = "meta\s+?name.*?description.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 2) = mc(0).SubMatches(0)

.Pattern = "meta\s+?name.*?keywords.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 3) = mc(0).SubMatches(0)

.Pattern = "<h1>(.*?)</h1>"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 4) = mc(0).SubMatches(0)

'その他要素（author、robots、copyright）を取得して出力
.Pattern = "meta\s+?name.*?author.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 5) = mc(0).SubMatches(0)

.Pattern = "meta\s+?name.*?robots.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 6) = mc(0).SubMatches(0)

.Pattern = "meta\s+?name.*?copyright.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 7) = mc(0).SubMatches(0)

'OGPの各パラメータを取得して出力
.Pattern = "meta\s+?property.*?og:title.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 8) = mc(0).SubMatches(0)

.Pattern = "meta\s+?property.*?og:description.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 9) = mc(0).SubMatches(0)

.Pattern = "meta\s+?property.*?og:image.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 10) = mc(0).SubMatches(0)

.Pattern = "meta\s+?property.*?og:url.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 11) = mc(0).SubMatches(0)

.Pattern = "meta\s+?property.*?og:type.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 12) = mc(0).SubMatches(0)

.Pattern = "meta\s+?property.*?og:site_name.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 13) = mc(0).SubMatches(0)

.Pattern = "meta\s+?property.*?fb:admins.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 14) = mc(0).SubMatches(0)

'twitterの各パラメータを取得して出力
.Pattern = "meta\s+?property.*?twitter:account_id.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 15) = mc(0).SubMatches(0)

.Pattern = "meta\s+?name.*?twitter:card.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 16) = mc(0).SubMatches(0)

.Pattern = "meta\s+?name.*?twitter:site.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 17) = mc(0).SubMatches(0)

.Pattern = "meta\s+?name.*?twitter:image:src.*?content=.*?[‘""](.*?)[‘""]"
Set mc = .Execute(buf)
If mc.Count <> 0 Then url.Offset(0, 18) = mc(0).SubMatches(0)

End With
Set url = url.Offset(1, 0)
Loop
Set Http = Nothing
Set re = Nothing
End Sub

参考記事

• エクセルでメタタグを抽出するには？ – 楽天 みんなで解決！Ｑ＆Ａ
• エクセルでURLからタイトルのみを抽出する方法 – Visual Basic – 教えて！goo
  ※UTF-8の文字化け制御部分はこの記事のベストアンサーを参考にしました

Amazon

Excel VBAでIEを思いのままに操作できるプログラミング術 Excel 2013/2010/2007/2003対応	ストーリーで学ぶ Excel VBAと業務改善のポイントがわかる本 【演習問題付き】	Excel VBAのプログラミングのツボとコツがゼッタイにわかる本―最初からそう教えてくれればいいのに!Excel2007/2003対応