URL取得でマクロが途中で長時間止まったままになってしまう

最近の書き込み件数：今日 0件、昨日 0件
未読分：2件

Excel VBAでIEを思いのままに操作できるプログラミング術 Excel 2013/2010/2007/2003対応

近田伸矢, 植木悠二, 上田寛

IEのデータ収集＆自動操作のプログラミング本はこの1冊だけ！IEの起動やポップアップウィンドウ、表示を制御する基本的なコードはもちろん、テキストボックスやラジオボタン、表、ハイパーリンクなどのHTML部品を制御する方法など、自動操作に欠かせないノウハウを丁寧に解説。

Message#2 2015年6月30日(火)00時30分
From: 気ずる

返事削除変更

Callで呼び出している部分の記載がないので、全部の確認はできていませんが、検索プロシージャ単独処理では問題なく抽出はできていますね。

全体的な処理を見るとループ処理で検索結果を抽出するような形で制御しているかと思いますが、「異なるトラフィックが検出されました」はおそらくGoogleに自動化によるトラフィックであると認識されたため、はじかれたのではないかと思います。

https://support.google.com/websearch/answer/86640?hl=ja

こちらに一例がありますが、

ユーザーのネットワークのパソコンまたはスマートフォンから Google に自動化されたトラフィックが送信されている可能性がある場合、「ご利用のコンピュータネットワークから通常以上のトラフィックが検出されました」というメッセージが表示されることがあります。

とあります。
異なるトラフィックとは書いていませんが、これに近いのではないでしょうか。

対処方としてはなるべく検知されないよう処理時間をあけたり、ランダムで待機時間をかえるなどの対応をすれば、でなくなるかもしれません。

Message#1 2015年6月29日(月)20時57分
From: Carib

返事削除変更

エクセルから検索ワードをグーグルで検索し、検索結果のURLを取得する作業を行っておりました。最近、海外から戻ってきて、日本でマクロを実行したところ、グーグルでは「異なるトラフィックが検出されました」とIE上で出てくるようになりました。これは、クエリを作成できていないということでしょうか。それと関係があるのかわかりませんが、マクロが止まったままの時間がかなり長くなってしまい、たった５つのワードをループで検索かけても、１時間以上も止まったままになり、タスクマネージャーで強制的にエクセルを終了する始末です。何か良い方法があれば教えていただけませんでしょうか。

Declare Function GetInputState Lib "USER32" () As Long
Private m_Time As Variant

Public Sub キー取得()

Dim x As Long
Dim y As Long
Dim start As Long
Dim key As String
Dim lr As Long
Dim rnk As Long
Dim shr As Long
Dim h As Long
Dim j As Long
Dim i As Long
Dim moji1 As String
Dim moji2 As String
Dim ws As Worksheet
Dim c As Range
Dim k As Long
Dim s As String
Dim m As Variant
Dim dic As Object

Application.ScreenUpdating = False

On Error Resume Next

For j = 10 To 100

Sheets("検索キー").Range("B1").Value = Sheets("検索キー").Cells(j, 6).Value

Call 削除

For x = 1 To 5
start = (x - 1) * 10
key = Sheets("検索キー").Range("B1").Value
If key = "" Then
Exit Sub
End If

'keyをぐぐって結果をシートに貼り付け
Call 検索(start, key)
'検索結果の件数取得
Sheets("Webクエリ").Select
lr = Range("B1048576").End(xlUp).Row

hr = Sheets("検索キー").Range("B1048576").End(xlUp).Row

Call GetURL

shr = Sheets("検索キー").Range("B1048576").End(xlUp).Row + 1
If shr <= 10 Then
shr = 10
End If

rnk = Sheets("検索キー").Range("B1048576").End(xlUp).Row - 8

For y = hr To lr
If Cells(y, 2).Value <> "" And Cells(y, 1).Value <> "類似ページ" And Cells(y, 1).Value <> "キャッシュ" Then
If IsNumeric(Left(Cells(y, 1).Value, 1)) Or Right(Cells(y, 2).Value, 3) = "pdf" Then
Sheets("検索キー").Cells(shr, 1).Value = rnk

If Right(Cells(y, 2).Value, 3) = "pdf" Then
Sheets("検索キー").Cells(shr, 2).Value = Cells(y, 1).Value

Else

Sheets("検索キー").Cells(shr, 2).Value = Mid(Cells(y, 1).Value, InStr(Cells(y, 1).Value, ".") + 2, 999)

End If

Sheets("検索キー").Cells(shr, 3).Value = Cells(y, 2).Value
shr = shr + 1
rnk = rnk + 1
End If
End If

Next

Call シート削除

Next

Set dic = CreateObject("Scripting.Dictionary") 'Like検索用語辞書
dic("*loco.yahoo*") = Empty
dic("*navitime*") = Empty

k = 7 'k は最初にコピーする列番号
Set ws = Worksheets("検索キー")
Set c = ws.Range("C10")
For Each c In Excel.Range(c, c.End(xlDown))
s = c.Value
For Each m In dic.Keys()
If s Like m Then
ws.Cells(j, k).Value = s
dic.Remove m
k = k + 1
Exit For
End If
Next
If k > 8 Then Exit For
Next
Next j

Application.ScreenUpdating = True

End Sub

Sub 検索(start As Long, key As String)
Application.ScreenUpdating = False
On Error GoTo myError

Dim i As Integer
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh2Row As Integer 'sh2の行を指定
Dim URL0 As String
Dim URL1 As String, URL2 As String, URL3 As String
Const Start2 As Integer = 100
URL1 = "http://www.google.co.jp/search?q="
URL2 = key
URL3 = "&start="

Set sh1 = Sheets.Add
sh1.Name = "Webクエリ"

'Webクエリ作成
URL0 = URL1 & URL2 & URL3 & start
With ActiveSheet.QueryTables.Add( _
Connection:="URL;" & URL0, _
Destination:=Range("A1"))
.Name = "Google検索結果 "
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.BackgroundQuery = False
.Refresh
End With

Columns("A:B").Select
With Selection
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Range("A25").Select
Exit Sub

myError:
Application.Wait Now + TimeValue("00:03:00")

End Sub