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

2013/12/3更新
1行目は各項目名の見出しとし、A2セルのURLから抽出するようにしました。
あと、H1、twitter:account_id、twitter:card、twitter:site、twitter:image:srcも抽出するようにしました。

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

参考記事

Amazon

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

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

コメントを残す