ExcelでURL一覧からタイトルを抽出するVBマクロを使う

EXCEL

以下などの情報をまとめた形になるが、、
http://qanda.rakuten.ne.jp/qa5617517.html?order=DESC&by=datetime

Webの訪問者分析、メディア分析をしているとどうしてもURLからタイトルを逆引き
したくなる場面に出くわす。その際はExcelで以下をマクロ登録しておくとよい。

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

Set Http = CreateObject("MSXML2.XMLHTTP")
Set url = Range("A3")
Do While (url.Value <> "")
Http.Open "GET", url.Value, False
Http.Send
'buf = StrConv(Http.ResponseBody, vbUnicode)

With CreateObject("ADODB.Stream")
.Open
.Type = 2 'adTypeText
.Charset = "unicode"
.Writetext Http.ResponseBody
.Position = 0
.Charset = "utf-8"
buf = .ReadText()
.Close
End With

'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