エクセル内のURLからHPのタイトルを抽出したい

質問

エクセル内のA列にURLがあるのですが、B列にそのURLのHPのタイトルだけを抽出する方法はありますか？
色々調べて
------------------------------------------
Public Sub ReadTitle()
Dim IE
Dim url As Range
Dim i As Integer

Set url = Range("A2")
Set IE = CreateObject("InternetExplorer.Application")

i = 0
Do While (url.Offset(i, 0).Value <> "")
IE.Navigate (url.Offset(i, 0).Value)
While IE.busy: Wend
While IE.Document.readyState <> "complete": Wend
url.Offset(i, 1).Value = IE.Document.Title
url.Offset(i, 3).Value = url.Offset(i, 2).Value '前回日付
url.Offset(i, 2).Value = IE.Document.LastModified
i = i + 1
Loop
End Sub

このようなマクロで抽出は出来たのですが、URLは1万件以上あり、PCのスペックの低さのせいか、何時間もかかってしまいます。

もっと早く、タイトルだけを抽出する方法は無いでしょうか？
よろしくお願いします。

回答No.4

mitarashi

>自分はとんでもなく無謀な事をしているような気になってきました。
まだ、初めの0.1歩くらいしか踏み出していませんよ。
VBEにはヘルプというものがありますので、Instrって何？と思ったら、検索してみてください。「使用例」の方をみてみると、およその様子が分かります。
下記にコードを載せます。'msgbox bufのところのシングルクォーテーションを外すと、何が起こっているか分かると思います。
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)
'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
htmlがシフトJISか、UNICODEかで分岐しないといけないと記してある記事もありますので、URLによって変なエラーが出る場合は参考URLをご覧下さい。

参考URL：

http://www.f3.dion.ne.jp/~element/msaccess/AcTipsVbaXMLHTTP.html

お礼

出来ました！！
本当にありがとうございました（T_T）
面倒な質問者でご迷惑をおかけしました、ありがとうございます！

回答No.3

mitarashi

>Sample = ........の部分に赤字でエラーが出るのですが、ここには何を入れるのでしょうか？
ここは自分で書いてねという事なので、エラーが出て当たり前です。
文字列変数bufに、htmlが丸ごと入ります。Instr関数で、<title>??????</title>の、<title>と、</title>それぞれの位置を求め、Mid関数で、??????の部分を取得してはいかがですか、という意味です。今日はもう寝ます。

お礼

自分はとんでもなく無謀な事をしているような気になってきました。
何度もすみません、先ほども言った様にまるで知識がないのですが、Sample=の後にhtmlを入れると構文エラーと出て
Private Function Sample(url As String) As String
の部分が黄色くなります。
文字列変数bufやInstr関数というのも、どこを指すのか解からないのです。
ちなみに、htmlを入れる場所には、タイトルを抽出したいURLが1万件あれば、1万件入力すると言う事でしょうか？
お時間があるときで結構ですのでよろしくお願いします。

回答No.2

mitarashi

>これだと1件1件の手作業になってしまいます。
質問文のコードを書ける方のコメントとも思えませんが、下記の様にやれば良いのではないでしょうか。ソース中の<title>?????</title>の部分を見つけるのは、正規表現を持ち出すまでもなく、Instr関数で十分だと思います。便宜上、関数を呼び出す度に、CreateObject("MSXML2.XMLHTTP")～解放を行っていますが、ループの最初だけで行い、最後に解放する様にした方が速度上有利だと思います。
Public Sub ReadTitle()
Dim url As Range
Dim i As Integer

Set url = Range("A2")
i = 0
Do While (url.Offset(i, 0).Value <> "")
url.Offset(i, 1).Value = Sample(url.Offset(i, 0).Value)
i = i + 1
Loop
End Sub

Private Function Sample(url As String) As String
Dim Http, buf As String
Set Http = CreateObject("MSXML2.XMLHTTP")
Http.Open "GET", url, False
Http.Send
buf = StrConv(Http.ResponseBody, vbUnicode)
'ここで、buf中の<title>??????</title>を見つけ、戻り値として返す
Sample = ........
Set Http = Nothing
End Function

お礼

説明不足でした。。。
質問のマクロは方法を探していたときにたまたま発見したもので、私自信は全く知識はありません。
mitarashi様が記載して頂いたマクロも貼り付けてみたのですが、エラーがでてしまい、どこがどうなのかイマイチ理解はしておりません。
Sample = ........
の部分に赤字でエラーが出るのですが、ここには何を入れるのでしょうか？

回答No.1

mitarashi

htmlをダウンロードして、テキストとして処理してはいかがでしょうか。

参考URL：

http://officetanaka.net/other/extra/tips02.htm

お礼

回答ありがとうございます。
参考URLを参考にし、やってみたのですがいまいちうまく行きません。
ソースをとるマクロのようですが、これだと1件1件の手作業になってしまいます。
なるべく早い時間で、タイトルだけを抜き出したいのです。
難しいのかもしれませんが、引き続きよろしくお願いします。