こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

それが以下になります。

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


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

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

よろしくお願いします!

投稿日時 - 2011-07-21 21:06:20

QNo.6890739

すぐに回答ほしいです

質問者が選んだベストアンサー

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

投稿日時 - 2011-07-22 15:03:17

お礼

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

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

本当に感謝します。

投稿日時 - 2011-07-22 16:36:21

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

列Cのdescription、列Dのkeywordが列Bにどのような記述をされているのか?

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

投稿日時 - 2011-07-22 00:58:56