VBA マクロが途中で止まるバグの解決策について(DoEventsでも解決出来ない)

質問です。
エクセルVBAでスクレイピングツールを開発中なのですが、マクロが途中で止まってしまいます。ループ処理の終わりにDoEvntsを入れたのですが全く解決出来ません。

止まってしまうので、タスクマネージャーでIEを無理やり終了させました。するとエクセルVBA"オートメーションエラーです。リモートプロシージャコールに失敗しました。"とエラーが出てしまいます。

以下エクセルVBAコードです。

Dim Search As String

Private Sub CommandButton1_Click()
Dim ELInteger2 As Integer
Dim ELInteger As Integer
Dim ELStringer5 As String
Dim ELStringer4 As String
Dim ELStringer3 As String
Dim ELStringer2 As String
Dim ELStringer As String
Dim SPDate3 As String
Dim SPDate2 As String
Dim SPDate As String
Dim Colect5 As IHTMLElementCollection
Dim Colect4 As IHTMLElementCollection
Dim Colect3 As IHTMLElementCollection
Dim Colect2 As IHTMLElementCollection
Dim Colect As IHTMLElementCollection
'Dim interNet5 As InternetExplorer
'Dim interNet4 As InternetExplorer
'Dim interNet3 As InternetExplorer
Dim ChangeExplorer1 As InternetExplorer
Dim ChangeExplorer2 As InternetExplorer
Dim ChangeExplorer3 As InternetExplorer
Dim interNet2 As InternetExplorer
Dim interNet As InternetExplorer
Dim HTMLD5 As HTMLDocument
Dim HTMLD4 As HTMLDocument
Dim HTMLD3 As HTMLDocument
Dim HTMLD2 As HTMLDocument
Dim HTMLD As HTMLDocument
Dim Sisokuenzan As String
Dim kasan As String
Dim ELInteger10 As Integer

ELInteger10 = 0
ELIntegerB = 0
ELIntegerC = 0

ELIntegerCount6 = 4
ELIntegerCount5 = 4
ELIntegerCount4 = 4

ELIntegerCount3 = 4
ELIntegerCount2 = 4
ELIntegerCount1 = 4

Dim ELIntegerCountStringer1 As String
Dim ELIntegerCountStringer2 As String
Dim ELIntegerCountStringer3 As String
Dim ELIntegerCountStringer4 As String
Dim ELIntegerCountStringer5 As String
Dim ELIntegerCountStringer6 As String
Dim ELIntegerM As Integer
ELIntegerM = 4
Dim ELIntegerM2 As Integer
ELIntegerM2 = 4
Dim ELIntegerM3 As Integer
ELIntegerM3 = 4
Dim ELStringerM As String
Dim ELStringerM2 As String
Dim ELStringerM3 As String

'ブランド検索処理(メインルーチンA)
Set interNet2 = CreateObject("internetexplorer.Application")
interNet2.Visible = False
kasan = ".html"
Sisokuenzan = Search + kasan
interNet2.navigate "http://www.buyma.com/brand/" & Sisokuenzan

Do While interNet2.Busy = True Or interNet2.readyState < READYSTATE_COMPLETE
DoEvents
Loop

'バイヤーランキング抽出処理(メインルーチンB)
Set HTMLD = interNet2.document
Set Colect = HTMLD.getElementsByClassName("vmimg_120")


'バイヤーランキング抽出処理1(サブルーチンB-1)
For Each EL In Colect
SPDate = EL.innerHTML
ELStringer = Mid(SPDate, 95)
ELInteger = InStr(ELStringer, "l")
ELStringer2 = Left(ELStringer, ELInteger)

'バイヤーランキング抽出処理2(サブルーチンB-2)
Set interNet3 = CreateObject("Internetexplorer.Application")
interNet3.Visible = False
interNet3.navigate ELStringer2
Debug.Print ELStringer2

Do While interNet3.Busy = True Or interNet3.readyState < READYSTATE_COMPLETE
DoEvents
Loop

Set HTMLD2 = interNet3.document
Set Colect2 = HTMLD2.getElementsByClassName("profimg_wrap")

'バイヤーランキング抽出処理3(サブルーチンB-3)
For Each El2 In Colect2
SPDate2 = El2.innerHTML
ELStringer3 = Mid(SPDate2, 14)
ELInteger2 = InStr(ELStringer3, "http")
ELInteger4 = ELInteger2
ELStringer4 = Left(ELStringer3, ELInteger4)
ELIntegerA = InStr(ELStringer4, "alt") + 5
ELInteger6 = InStr(ELIntegerA, ELStringer4, """")
ELInteger8 = ELInteger6 - ELIntegerA
ELStringer5 = Mid(ELStringer4, ELIntegerA, ELInteger8)
DoEvents
Next El2

'バイヤーランキング最終抽出処理(サブルーチンB-4)
ELInteger10 = ELInteger10 + 1
If ELInteger10 = 1 Then
Range("A1").Value = "ランキング1位:" & ELStringer5
Debug.Print ELStringer5
ElseIf ELInteger10 = 2 Then
Range("D1").Value = "ランキング2位:" & ELStringer5
Debug.Print ELStringer5
ElseIf ELInteger10 = 3 Then
Range("G1").Value = "ランキング3位:" & ELStringer5
Debug.Print ELStringer5
End If

'バイヤー販売リスト処理(メインルーチンC)
ELInteger12 = InStr(ELStringer4, ".html") - 1
ELStringer13 = Left(ELStringer4, ELInteger12)

Set interNet4 = CreateObject("Internetexplorer.Application")
interNet4.Visible = False
interNet4.navigate "http://www.buyma.com/" & ELStringer13 + "/sales_1.html"

Do While interNet4.Busy = True Or interNet4.readyState < READYSTATE_COMPLETE
DoEvents
Loop

Set HTMLD3 = interNet4.document
Set Colect3 = HTMLD3.getElementsByClassName("data_line0")
'Set HTMLD4 = interNet4.document
'Set Colect4 = HTMLD4.getElementsByClassName("data_line1")

'商品リスト抽出処理1(サブルーチンC-4)
ELIntegerB = ELIntegerB + 1
If ELIntegerB = 1 Then
For Each El3 In Colect3
ELIntegerCount1 = ELIntegerCount1 + 1
ELIntegerCountStringer1 = ELIntegerCount1
SPDate10 = El3.innerText
Range("A" & ELIntegerCountStringer1).Value = SPDate10
DoEvents
Next El3
End If

'金額抽出処理1(サブルーチンC-1）
ELIntegerC = ELIntegerC + 1
If ELIntegerC = 1 Then
For Each ELD In Colect3
ELStringer15 = ELD.innerHTML
ELStringer17 = Mid(ELStringer15, 168)
ELInteger18 = InStr(ELStringer17, """>")
ELStringer20 = Left(ELStringer17, ELInteger18)
ELInteger100 = Len(ELStringer20)
ELInteger200 = ELInteger100 - 2
ELStringer24 = Left(ELStringer20, ELInteger200)
ELInteger2000 = Len(ELStringer24)
ELInteger4000 = ELInteger2000 - 15
ELStringer1000 = Right(ELStringer24, ELInteger4000)
Debug.Print ELStringer1000

Set interNet5 = CreateObject("Internetexplorer.Application")
interNet5.Visible = False
interNet5.navigate "http://www.buyma.com/item/" & ELStringer1000

Do While interNet5.Busy = True Or interNet5.readyState < READYSTATE_COMPLETE
'↑エラーの原因はココ
DoEvents
Loop

Set HTMLD5 = interNet5.document
Set Colect5 = HTMLD5.getElementsByClassName("price_txt")

For Each ELP In Colect5
ELIntegerM = ELIntegerM + 1
ELStringerM = ELIntegerM
Range("B" & ELStringerM).Value = ELP.innerText
interNet5.Quit
Set interNet5 = Nothing
DoEvents
Next ELP
DoEvents
Next ELD
End If

'商品リスト抽出処理2(サブルーチンC-5)
If ELIntegerB = 2 Then
For Each El4 In Colect3
ELIntegerCount2 = ELIntegerCount2 + 1
ELIntegerCountStringer2 = ELIntegerCount2
SPDate10 = El4.innerText
Range("C" & ELIntegerCountStringer2).Value = SPDate10
DoEvents
Next El4
End If

'金額抽出処理2(サブルーチンC-2)
If ELIntegerC = 2 Then
For Each ELD In Colect3
ELStringer15 = ELD.innerHTML
ELStringer17 = Mid(ELStringer15, 168)
ELInteger18 = InStr(ELStringer17, """>")
ELStringer20 = Left(ELStringer17, ELInteger18)
ELInteger100 = Len(ELStringer20)
ELInteger200 = ELInteger100 - 2
ELStringer24 = Left(ELStringer20, ELInteger200)
ELInteger2000 = Len(ELStringer24)
ELInteger4000 = ELInteger2000 - 15
ELStringer1000 = Right(ELStringer24, ELInteger4000)

Set interNet5 = CreateObject("Internetexplorer.Application")
interNet5.Visible = False
interNet5.navigate "http://www.buyma.com/item/" & ELStringer1000

Do While interNet5.Busy = True Or interNet5.readyState < READYSTATE_COMPLETE
DoEvents
Loop

Set HTMLD5 = interNet5.document
Set Colect5 = HTMLD5.getElementsByClassName("price_txt")

For Each ELP In Colect5
ELIntegerM2 = ELIntegerM2 + 1
ELStringerM2 = ELIntegerM2
Range("D" & ELStringerM2).Value = ELP.innerText
interNet5.Quit
Set interNet5 = Nothing
DoEvents
Next ELP
DoEvents
Next ELD
End If

'商品リスト抽出処理3(サブルーチンC-6)
If ELIntegerB = 3 Then
For Each El5 In Colect3
ELIntegerCount3 = ELIntegerCount3 + 1
ELIntegerCountStringer3 = ELIntegerCount3
SPDate10 = El5.innerText
Range("E" & ELIntegerCountStringer3).Value = SPDate10
DoEvents
Next El5
End If

'金額抽出処理3(サブルーチンC-3)
If ELIntegerC = 3 Then
For Each ELD In Colect3
ELStringer15 = ELD.innerHTML
ELStringer17 = Mid(ELStringer15, 168)
ELInteger18 = InStr(ELStringer17, """>")
ELStringer20 = Left(ELStringer17, ELInteger18)
ELInteger100 = Len(ELStringer20)
ELInteger200 = ELInteger100 - 2
ELStringer24 = Left(ELStringer20, ELInteger200)
ELInteger2000 = Len(ELStringer24)
ELInteger4000 = ELInteger2000 - 15
ELStringer1000 = Right(ELStringer24, ELInteger4000)

Set interNet5 = CreateObject("Internetexplorer.Application")
interNet5.Visible = False
interNet5.navigate "http://www.buyma.com/item/" & ELStringer1000

Do While interNet5.Busy = True Or interNet5.readyState < READYSTATE_COMPLETE
DoEvents
Loop

Set HTMLD5 = interNet5.document
Set Colect5 = HTMLD5.getElementsByClassName("price_txt")

For Each ELP In Colect5
ELIntegerM3 = ELIntegerM3 + 1
ELStringerM3 = ELIntegerM3
Range("F" & ELStringerM3).Value = ELP.innerText
interNet5.Quit
Set interNet5 = Nothing
DoEvents
Next ELP
DoEvents
Next ELD
End If

'商品リスト抽出処理4(サブルーチンC-7)
'ELIntegerC = ELIntegerC + 1
'If ELIntegerC = 1 Then
'For Each El6 In Colect4
'ELIntegerCount4 = ELIntegerCount4 + 1
'ELIntegerCountStringer4 = ELIntegerCount4
'SPDate11 = El6.innerText
'Range("Z" & ELIntegerCountStringer4).Value = SPDate11
'Next El6
'
'商品リスト抽出処理5(サブルーチンC-8)
'ElseIf ELIntegerC = 2 Then
'For Each El7 In Colect4
'ELIntegerCount5 = ELIntegerCount5 + 1
'ELIntegerCountStringer5 = ELIntegerCount5
'SPDate11 = El7.innerText
'Range("Y" & ELIntegerCountStringer5).Value = SPDate11
'Next El7
'
''商品リスト抽出処理6(サブルーチンC-9)
'ElseIf ELIntegerC = 3 Then
'For Each El8 In Colect4
'ELIntegerCount6 = ELIntegerCount6 + 1
'ELIntegerCountStringer6 = ELIntegerCount6
'SPDate11 = El8.innerText
'Range("X" & ELIntegerCountStringer6).Value = SPDate11
'Next El8
'End If

interNet3.Quit
Set interNet3 = Nothing
interNet4.Quit
Set interNet4 = Nothing
DoEvents
Next EL
interNet2.Quit
Set interNet2 = Nothing
End Sub

'スクレイピング開始処理
Private Sub CommandButton2_Click()
End Sub

'バイヤーリスト抽出処理
Private Sub CommandButton3_Click()
End Sub

Private Sub TextBox1_Change()
Search = TextBox1.Value
End Sub

Private Sub UserForm_Click()
End Sub

グーグルでエラー原因を検索しながら、トライアンドエラーを繰り返しましたが結局原因が分かりませんでした。

詳しい方、対処方法をご教示して頂ければと存じます。
宜しくお願い致します。

行動規範の内容に同意します

回答1件

ベストアンサー

原因はわかりませんが、当方の環境で実行した限りでは、時間はかかりましたが最後まで実行できました(Excel2010)
Searchには"_ADIDAS-アディダス"を設定しました。
実行中、ツールバーの一時停止も停止も押せるので、DoEventsはきちんと効いているようです。
止まってしまうというのは、上記のように一時停止も停止もできないのでしょうか？
単に時間がかかっているだけということは？

投稿2017/05/09 01:28

ttyp03

総合スコア17000

Susanoo2442

2017/05/09 06:20

ご回答ありがとうございます。止まってしまうとの事でしたが、具体的にはプログラム自体が進行しなくなる状態を指させて頂いたつもりでした。最終的にReadyStateの返り値をLOADEDに指定すると、プログラムが再度進行する様になりました。しかしながら、落ち目の無い点としましては、ゴールデンウィークに入る前に一度、プログラムを実行していたのですが、その際は、ReadyStateのCOMPLET_STATEという返り値でも動いていました。それが、GW明けにプログラムを実行してみると、今回質問させて頂いた様に、上記の返り値では、動かなくなっておりました。やはり、ttyp様が仰られた通り、単に時間がかかって頂けなのかもしれません。IEは回線や接続状況等によって速度がマチマチですので、もう少し、慎重にロジックを考えながらコードを書いて行きたいと思います。ありがとうございました！

行動規範の内容に同意します