エクセルでメタタグを抽出するには？

質問

すいません、前回質問した者です。
前回の質問では・・・

エクセルシートのB列にURLが並んでいるとして、ＶＢＡを使って、C列には「description」D列には「keywords」を抽出したいという質問をしたのですが、参考になる回答がなかったのでもう一度質問します。

以前、私が教えてもらったのは、B列にURLが並んでいて、Ａ列にタイトルを抽出させたものでした。

それが以下になります。

Public Sub ReadTitle()
Dim url As Range
Dim Http, buf As String

Set Http = CreateObject("MSXML2.XMLHTTP")
Set url = Range("B1")
Do While (url.Value <> "")
Http.Open "GET", url.Value, False
Http.Send
buf = StrConv(Http.ResponseBody, vbUnicode)
'msgbox buf
url.Offset(0, -1).Value = getTitle(buf)
Set url = url.Offset(1, 0)
Loop
Set Http = Nothing
End Sub

Private Function getTitle(buf As String) As String
Dim pos1 As Long, pos2 As Long

pos1 = InStr(1, buf, "<title>")
If pos1 = 0 Then
pos1 = InStr(1, buf, "<TITLE>")
If pos1 = 0 Then
getTitle = ""
Exit Function
Else
pos2 = InStr(pos1 + 7, buf, "</TITLE>")
End If
Else
pos2 = InStr(pos1 + 7, buf, "</title>")
End If
getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7)
End Function

このような感じでＢ列にはURLの一覧があるとして、Ａ列にタイトル、C列にdescription　D列にkeywordsが抽出できればいいなと考えています。

ちなみに、私にはＶＢＡの知識がまったくありません。とりあず、これだけ出来れば、すごく助かるのですが、どなたか教えていただけないでしょうか？　

よろしくお願いします！

回答No.2

jcctaira · ベストアンサー

torasan117さん　こんにちは。
HTMLの記述は自由(スペースや改行等々）なのと、文字コード(S-Jis,UTF8等々）の違いもあり
各サイトを確認しないと、きちんとしたデータを収集できないかも知れません。

一応サンプルを作成してみましたが、うまくいかない時は自分で修正して欲しいのですが
「VBAの知識がない」とのことで厳しいかも知れません。

今回はdescription、keywordsの取得がタイトル取得より面倒なので「正規表現」を使用しました。
正規表現のパターン（抽出条件？）を理解すれば修正も可能かと思います。

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("B1")
Do While (url.Value <> "")
　Http.Open "GET", url.Value, False
　Http.Send
　buf = StrConv(Http.ResponseBody, vbUnicode)
　buf = Replace(buf, vbCr, " ")
　buf = Replace(buf, vbLf, " ")
　With re
　　.IgnoreCase = True
　　.Global = True
　　.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, 1) = mc(0).SubMatches(0)
　　.Pattern = "meta\s+?name.*?keywords.*?content=.*?['""](.*?)['""]"
　　Set mc = .Execute(buf)
　　If mc.Count <> 0 Then url.Offset(0, 2) = mc(0).SubMatches(0)
　End With
　Set url = url.Offset(1, 0)
Loop
Set Http = Nothing
Set re = Nothing
End Sub

お礼

回答ありがとうございます。

思っていたことが出来ました。

本当に感謝します。

回答No.1

bin-chan

列Ｃのdescription、列Ｄのkeywordが列Ｂにどのような記述をされているのか？

前質問の＃１さんの回答のとおりですが、コードを列挙するよりも列Ｂを例示しないと難しいですよ。