【Excelマクロ】URL一覧からMETA情報を抽出してB列~に書き出す
2013/12/3更新
1行目は各項目名の見出しとし、A2セルのURLから抽出するようにしました。
あと、H1、twitter:account_id、twitter:card、twitter:site、twitter:image:srcも抽出するようにしました。
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
参考記事
- エクセルでメタタグを抽出するには? – 楽天 みんなで解決!Q&A
- エクセルでURLからタイトルのみを抽出する方法 – Visual Basic – 教えて!goo
※UTF-8の文字化け制御部分はこの記事のベストアンサーを参考にしました
Amazon
Excel VBAでIEを思いのままに操作できるプログラミング術 Excel 2013/2010/2007/2003対応 |
ストーリーで学ぶ Excel VBAと業務改善のポイントがわかる本 【演習問題付き】 |
Excel VBAのプログラミングのツボとコツがゼッタイにわかる本―最初からそう教えてくれればいいのに!Excel2007/2003対応 |
Pingback: 【Excel】URL一覧からTITLE,META,og:imageなどの情報を抽出する方法~WEBサイトのスクレイピング | Web活メモ帳