質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.92%

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

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 12K+

Susanoo2442

score 149

質問です。
エクセル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


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

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

+1

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/05/09 15:20

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

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.92%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る