"ソース内に指定したキーワードがあったら○が付くマクロ"を早くする

下記は、"ソース内に指定したキーワードがあったら○が付くマクロ"です。

A列にあるURLのソースを調べるこのマクロは、それなりに早いのですが、
今回調べるURLの量がとても多くて、どうにかもっと早く調べるようにしたいです。

マクロをもっと早く調べていくようにするには、どのような記述でできるでしょうか？
よろしくお願いいたします。


Sub リンゴ()
'!!!! [Microsoft XML v6.0] に参照設定すること
Dim xHttp As IServerXMLHTTPRequest
Dim myErr_Number As Long, myErr_Description As String
Set xHttp = CreateObject("MSXML2.ServerXMLHTTP")
Dim aCell As Range
R = 1
For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL
Application.GoTo aCell '対象URLの列にジャンプ表示
DoEvents
sUrl = aCell.Value
If sUrl <> "" Then
xHttp.Open "GET", sUrl, True
xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _
SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視
On Error Resume Next
xHttp.send
If xHttp.readyState <> 4 Then
xHttp.waitForResponse 5 '5秒まってだめならタイムアウト
End If
If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト"
myErr_Number = Err.Number
myErr_Description = Err.Description
On Error GoTo 0
If myErr_Number = 0 Then
sHtml = xHttp.responseText
nRtn = InStr(sHtml, "リンゴ")
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If
Else
aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示
End If
DoEvents
End If
Next
Set xHttp = Nothing
End Sub

質問者からの補足コメント

• Qchan1962さん、回答ありがとうございます！
  
  書いていただいたマクロをやってみました。
  
  前のマクロは、一つずつ調べていくのですが、
  こちらは、一気に結果が表示されるみたいです。
  
  調べたいURLは１万を越えるので、一つずつ結果が出たほうがいいかなと思いました。
  そして、本来「○」が付くところが付かないところがありました。
  
  質問のマクロは、だいぶ前に別の方に書いていただいたものです。
  私自身、マクロについて知識がないのですが、早くさせるのはなかなか難しいのかもしれません。
  
  どうにか、マクロを早くできたりしますでしょうか？

  No.2の回答に寄せられた補足コメントです。 補足日時：2021/06/20 23:42

No.2 回答者： Qchan1962 回答日時： 2021/06/20 02:10

＃１です

実験的に書いてみましたが、環境に依存される部分が多いので早くなるかな？
Sub リンゴ1()
'!!!! [Microsoft XML v6.0] に参照設定すること
Dim xHttp As IServerXMLHTTPRequest
Dim myErr_Number As Long, myErr_Description As String
Dim R As Long, sUrl As String, sHtml As String, nRtn As String
Dim TagetAry As Variant, Ary As Variant, i As Long
Set xHttp = CreateObject("MSXML2.ServerXMLHTTP")
R = 1
If Selection.Columns.Count = 1 Then
TagetAry = Selection.Cells
ReDim Ary(Selection.Count)
Else
Exit Sub
End If
If Not IsArray(TagetAry) Then
ReDim TagetAry(1, 1)
TagetAry(1, 1) = Selection.Cells
End If
For i = 1 To UBound(TagetAry)
DoEvents
sUrl = TagetAry(i, 1)
If sUrl <> "" Then
xHttp.Open "GET", sUrl, True
xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _
SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視
On Error Resume Next
xHttp.Send
If xHttp.readyState <> 4 Then
xHttp.WaitForResponse 5 '5秒まってだめならタイムアウト
End If
If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト"
myErr_Number = Err.Number
myErr_Description = Err.Description
On Error GoTo 0
If myErr_Number = 0 Then
sHtml = xHttp.ResponseText
nRtn = InStr(sHtml, "リンゴ")
If nRtn = 0 Then
Ary(i - 1) = "--"
Else
Ary(i - 1) = "○"
End If
Else
Ary(i - 1) = myErr_Description ' エラー時はエラー内容を表示
End If
DoEvents
End If
Next
Selection(1).Offset(, 1).Resize(UBound(Ary)) = Ary
Set xHttp = Nothing
End Sub

Timerなどを差し込んでテストしてみてください。

No.1 回答者： Qchan1962 回答日時： 2021/06/20 02:08

こんばんは、

しばらく放置されているようなので回答を付けさせていただきます。
プロシージャ全体を考えるとターゲットサイトのレスポンスやトラフィック、通信帯域（速度）に大きく影響を受ける処理だと思います。
従って処理自体、対象を分け同時処理したり、非同期処理を模索したり、処理言語の変更なども考慮する必要があるかも知れません。
しかしながら、処理速度に対する要因は変わらず残ります。

極端に言うと遅い通信速度の環境から複数のアクセスをしても通信速度がネックになり改善が見込めないとか、、

＞それなりに早いのですが
上記の影響を度返しにしてVBA的に時間がかかっている処理を変更する部分はあると思います。

同期通信で必要部分を除き、遅い部分Application.GoTo aCell
ループ内の　aCell.Offset(, 1).Value =　位でしょうか、

簡単な方法はおなじみ　Application.ScreenUpdating = False
これを使用しない場合、配列などに入れる方法になると思います。
（Application.GoTo aCellを別の方法にすればコレクション内のループなので変わらないかも）

変数Rが解らないのと速度を意識するのなら、変数宣言はした方が良いと思います。

続く