削除

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

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

上のメッセージを削除します。
よければパスワードを入力し、削除ボタンをクリックしてください。