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

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

最新20件 最新50件 最新100件 最新200件 200件以前
昨日以降(0) 2日前以降(0) 3日前以降(0) 4日前以降(0) 5日前以降(0)


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上で出てくるようになりました。これは、クエリを作成できていないということでしょうか。それと関係があるのかわかりませんが、マクロが止まったままの時間がかなり長くなってしまい、たった5つのワードをループで検索かけても、1時間以上も止まったままになり、タスクマネージャーで強制的にエクセルを終了する始末です。何か良い方法があれば教えていただけませんでしょうか。

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

最新20件 最新50件 最新100件 最新200件 200件以前
昨日以降 2日前以降 3日前以降 4日前以降 5日前以降

VBAのIE制御についてのQ&A掲示板

↑エクセルVBAのIE(InternetExplorer)操作で分からない事があればこちらの掲示板よりご質問ください^^

ExcelのVBA初心者入門

↑こちらはExcelのVBAをマスターできるよう初心者向けのエクセルVBA入門コンテンツになります^^

VBAのIE制御入門RSS

RSSフィードを登録すると最新記事を受け取ることができます。

VBAIE操作のスカイプレッスン

VBAでIE(InternetExplorer)制御の準備

エクセルVBAでIE制御の応用編

こちらでは、エクセルVBAで実際に作成したIE(InternetExplorer)制御ツールをまとめています。自動ログインや情報収集など具体的に解説しています。IE(InternetExplorer)制御をされる方は参考にしてください。

【ダウンロード】IE操作に便利なツール

こちらでは、これまでに紹介したIE(InternetExplorer)操作で便利な機能をツール化しています。無償でダウンロードできますので、目的に合わせたご利用ください。

IEオブジェクトのメソッド・プロパティ

こちらでは、IE(InternetExplorer)オブジェクトのメソッド・プロパティをまとめています。

IE操作に利用されているVBA関数

こちらでは、エクセルVBAのIE(InternetExplorer)操作で利用されたVBA関数をまとめています。

IE操作に利用されているステートメント

こちらでは、エクセルVBAのIE(InternetExplorer)操作で利用されたステートメントをまとめています。ExcelのVBAで基本的な部分になりますので、しっかり理解しましょう。

IE(InternetExplorer)制御のVBAコード

こちらでは、これまでに作成したIE(InternetExplorer)操作で役立つサブルーチンをまとめています。
全てをコピーする必要はありませんが、目的に合わせたサブルーチンをご利用ください。

ExcelのVBAで作成した役立つVBAコード

こちらでは、IE(InternetExplorer)制御の利用だけでなく、Excel全般で利用できるVBAコードです。エクセルVBAで役に立つものばかりですので、ご利用ください。

dmb.cgi Ver. 1.068
Copyright(C) 1997-2014, hidekik.com