URL取得でマクロが途中で長時間止まったままになってしまう
昨日以降(0) 2日前以降(0) 3日前以降(0) 4日前以降(0) 5日前以降(0)
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日前以降