URL取得でマクロが途中で長時間止まったままになってしまう
未読分:2件
昨日以降(0) 2日前以降(0) 3日前以降(0) 4日前以降(0) 5日前以降(0)
近田 伸矢, 植木 悠二, 上田 寛
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 |
昨日以降 2日前以降 3日前以降 4日前以降 5日前以降