サイトタイトルを取得するマクロが「応答なし」になる

質問

下記のマクロは、選択したセルのURLからサイトタイトルを取得するものです。

このマクロを使って、１万を越えるURLの作業をやろうとしています。

作業に取り掛かったのですが、下記のマクロがすぐに「応答なし」になり、
エクセルの画面が真っ白になり、Escでマクロを止めることもできません。

ようやくマクロを止めても応答なしのときはマクロが動いておらず、作業が進みません。

取得するサイトタイトルの数が多いため、
寝てるときにマクロを動かしてやっていきたいです。

下記のマクロを「応答なし」にせずに、順調にサイトタイトルを取得していくには、
どのような記述にすれば、できるようになるでしょうか？

EXCEL2016です。
よろしくお願いいたします。

↓応答なしになるマクロ

Sub サイトタイトル()
Dim rng As Range
Dim url As String
Dim s As String
For Each rng In Selection
url = rng.Value
If url <> "" Then
If url Like "*://*" Then
s = GetTitle(rng.Value)
Else
s = GetTitle("https://" & url)
If s = "Error" Then s = GetTitle("http://" & url)
If s = "Error" Then s = GetTitle("https://www." & url)
If s = "Error" Then s = GetTitle("http://www." & url)
End If
rng.Offset(, 1) = s
End If
Next
End Sub

Function GetTitle(url As String) As String
Dim http As Object
Dim html As Object
Set http = CreateObject("MSXML2.XMLHTTP")
Set html = CreateObject("htmlfile")
GetTitle = "Error"
On Error Resume Next
http.Open "GET", url, False
http.send
If http.Status <> 200 Then Exit Function
On Error GoTo 0
html.Write http.responseText
GetTitle = html.Title
End Function

回答No.2

superside0 · ベストアンサー

「応答なし」になるのは、マクロの処理時間が長くて、
Excelが長時間イベント処理を行えていないからです。

ループ内のどこか　（rng.Offset(, 1) = s　の行の次ぐらいに）
DoEvents
だけ書いた行をいれてはどうですか。

お礼

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

rng.Offset(, 1) = s　
のあとに、
DoEvents
と足して、動かしてみました。

ですが、変わらず「応答なし」になります。

できるだけ早くURLからサイトタイトルを取得していく、
というのが理想なのです。

他に、何か早く取得できる方法はありますでしょうか？
よろしくお願いいたします。

回答No.3

superside0

こちらで同じコードで実験したところ
たしかに、「応答なし」となりましたが、
ループ内にDoEventsを入れることで、解決しましたよ。
なにか、違うのでしょうね。

ただし、「応答なし」が解決しても
１件ごとに　Webアクセスして応答待ちする遅い処理ですし
通信環境次第で、ずいぶん性能差は出るでしょうね。

補足

PC自体が重くて、その理由から応答なしになってたようです。
クリーンアップなどをやって再起動してから試したら、スムーズに取得していけるようになりました！
どうもありがとうございます。

回答No.1

imogasi

この分野に詳しくないのですが、WEBで拾ってきたコードを多少改変してやってみました。
うまく行きそうなんですが,どうでしょう。
パターンとして、どういう場合に止まるか、の知識もないのですが。本当は質問の原因を指摘し
対応法を示せればよいのですが。
一種の「取り換え法」の提案です。下記はコード行数も少ないので、また基本的手法は同じかとおもった。
最初は、１００件とかに限って、小出しにしてやってみては。
質問者の場合の数が多いようなのと、実例を作りに手数がかかるので、少数でしか、やっていません。
ーーーー
VBE画面で、ツールー参照設定で,Microsoft XML. V6.0をチェック。エクセル２０１３でテスト。
A列にURLの文字列がある場合が頭にあるが、その場合は
Lr=range("A100000").End(xlup).Row
For i=2 to Lr
targetURI=cells(i,"A")
＜下記コードを多少修正し挟みこむ。＞
同行C列にタイトル文字を出すとする。
cells(i,"C")=ttl
Next i
＝＝＝＝
単発の場合のコード　URLは直接書き込み法
Sub httpRequest()

Dim HttpReq As Object 'MSXML2.XMLHTTP
Dim DomDoc As Object 'MSXML2.DOMDocument
Dim targetURL As String

targetURI = "https://www.以下略"

'HTTP GET
Set HttpReq = CreateObject("MSXML2.XMLHTTP")
HttpReq.Open "GET", targetURI, False
HttpReq.send (Null)

'XML PARSE
Set DomDoc = CreateObject("MSXML2.DOMDocument")

DomDoc.LoadXML (HttpReq.responseText)
txt = HttpReq.responseText
MsgBox txt　'テスト時以外はコメント化
p1 = InStr(txt, "<title>")
p2 = InStr(txt, "</title>")
ttl = Mid(txt, p1 + 7, p2 - p1 - 7) '実際は　Cells(i,"C")=ttlでシートにタイトル残す。
MsgBox ttl　'テスト時以外はコメント化
'dumpDomDoc DomDoc.ChildNodes

Set HttpReq = Nothing
Set DomDoc = Nothing
End Sub

お礼

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

質問のマクロは、前に別の方に書いてもらったものです。
私自身は、マクロの知識がなく応用も利かないため、質問させていただいた次第です。

・単発の場合のコード　URLは直接書き込み法
のあとのマクロを、そのまま使えばいいのでしょうか？

記述を足す箇所がありますか？
よろしくお願いいたします。