VBA スクレイピングプログラムのエラー

Question

VBAでスクレイピングプログラムを作成したのですが、
100サイトくらいスクレイピングを行うとエラーが発生します。
50サイトづつに分けると問題なくプログラムが最後まで動きます。
原因、改善方法がわかる方アドバイス頂ければ有り難いです。

Private Function a(btAry As String)

    Application.ScreenUpdating = False
        
    Dim i As Long
    Dim urlLen As Long
    Dim urlStr() As String
    Dim tAry() As String
    
    urlStr() = Split(btAry, ",")
    urlLen = UBound(urlStr) 
    
    
    ReDim tAry(urlLen, 1) As String
    
    For i = 0 To urlLen - 1
        tAry(i, 0) = urlStr(i)
    sleep (1)
    Next
        
    Dim ie As InternetExplorer
    Dim htdoc As HTMLDocument
    Dim tagName As HTMLElementCollection
    
    Set ie = CreateObject("InternetExplorer.Application")
    
    ie.Visible = True
    ie.Top = True
    ie.Left = True
    ie.Width = 500
    ie.Height = 500
        
    For i = 0 To urlLen - 1
        Debug.Print i & " / " & urlLen - 1
        ie.Navigate tAry(i, 0)
        
        Do While ie.Busy Or ie.ReadyState < READYSTATE_COMPLETE
            DoEvents
        Loop
        
        Set htdoc = ie.Docum
        ent
     

        If InStr(htdoc.URL, "") > 0 Then
            For Each tagName In htdoc.getElementsByClassName("")
                If InStr(tagName.outerText, "") > 0 Then
                    tAry(i, 1) = "×"
                    Exit For
                End If
            Next
        End If


        Set htdoc = Nothing
        Set tagName = Nothing
    sleep 1
    Next
       
    ie.Quit
    
    Set ie = Nothing
    Set htdoc = Nothing
        
    Dim num As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    num = ws.Cells(1, 1).CurrentRegion.Rows.Count - 1
    
    For i = 0 To num - 2
        If ws.Cells(i + 2, 1).value = tAry(i, 0) Then
            ws.Cells(i + 2, 3).value = tAry(i, 1)
        End If
    sleep 1
    Next
    
    Set ws = Nothing
        
End Function

何回か試して見ると別のエラーもでました。

↓tagNameはこちらで定義しています。
Dim tagName As HTMLElementCollection

Comments

[h.horikoshi]

【依頼】保護モードを確認してみてください。→エラーの発生した時点で、IEには問題となったWebページが表示されていると思いますが、そのページ上で、右クリック→プロパティと操作。→「ゾーン」の行はどのような値になっていますか? 保護モード=「有効」ならOKですが、「無効」だと問題ありかもです。

[blacksanta]

保護モードは「有効」になっていました。

[h.horikoshi]

確認ありがとうございました。"有効"ならば問題なさそうですね。 ※私の経験ですが、 以前、Navigationまではできるのにその後の操作ができない。という状況になり、 そのときは、保護モードとIEオブジェクト InternetExplorer.Application or InternetExplorer.ApplicationMedium の組み合わせが原因でしたので。

Answer 1

100サイトくらいスクレイピングを行うとエラーが発生します。
50サイトづつに分けると問題なくプログラムが最後まで動きます。

コードは読んでいませんが、単純に考えられるのはメモリリークとかでしょうか。
例えば30回毎にieオブジェクトを破棄して、改めてCreateObjectするようにしたら改善するかもしれません。

Private Function urlscr(btAry As String)

    Application.ScreenUpdating = False

    Dim i As Long
    Dim urlLen As Long
    Dim urlStr() As String
    Dim tAry() As String

    urlStr() = Split(btAry, ",")
    urlLen = UBound(urlStr)

    ReDim tAry(urlLen, 1) As String

    For i = 0 To urlLen - 1
        tAry(i, 0) = urlStr(i)
        Sleep (1)
    Next

    Dim ie As InternetExplorer
    Dim htdoc As HTMLDocument
    Dim tagName As HTMLElementCollection

'変更箇所　ここから
    Const ResetPages = 30
    
    For i = 0 To urlLen - 1
        If i Mod ResetPages = 0 Then
            If Not ie Is Nothing Then
                ie.Quit
            End If
            
            Set ie = CreateObject("InternetExplorer.Application")
        
            ie.Visible = True
            ie.Top = True
            ie.Left = True
            ie.Width = 500
            ie.Height = 500
        End If
'変更箇所　ここまで
        
        Debug.Print i & " / " & urlLen - 1
        ie.Navigate tAry(i, 0)

        Do While ie.Busy Or ie.ReadyState < READYSTATE_COMPLETE
            DoEvents
        Loop

        Set htdoc = ie.document

        If InStr(htdoc.Url, "") > 0 Then
            For Each tagName In htdoc.getElementsByClassName("")
                If InStr(tagName.outerText, "") > 0 Then
                    tAry(i, 1) = "×"
                    Exit For
                End If
            Next
        End If


        Set htdoc = Nothing
        Set tagName = Nothing
        Sleep 1
    Next

    ie.Quit

    Set ie = Nothing
    Set htdoc = Nothing

    Dim num As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    num = ws.Cells(1, 1).CurrentRegion.Rows.Count - 1

    For i = 0 To num - 2
        If ws.Cells(i + 2, 1).Value = tAry(i, 0) Then
            ws.Cells(i + 2, 3).Value = tAry(i, 1)
        End If
    Sleep 1
    Next

    Set ws = Nothing

End Function

それと、100サイト回した時に、何回目くらいでエラーが出るのか、エラーが出たサイトを序盤に実行した場合に同じサイトでエラーにならないか。
といった法則性について調査されていないので調べてみたほうが良いかもしれません。

Comments

[blacksanta]

ありがとうございます！
何回目でエラーが出るか、エラーが出るサイトは毎回変わりました。
一度エラーが出たサイトでももう一回VBAを実行するとエラーなくスクレイピングできたりします。
エラーが出たサイトを序盤に実行した場合も同じサイトでエラーにならなかったです。

[退会済みユーザー]

肝心のieを再起動する部分を試していただけてないようなので、サンプルコードを追記しました。ご確認ください。
本当はエラーが出る回数が定かではないので、エラーをハンドルしたら再起動というコードも考えたんですけど流れが複雑になりそうなので、とりあえず30回でieを再起動する例です。

Answer 2

IE11でしょうか。
待ち時間処理を工夫することで
症状が緩和する可能性があります。
よろしければ試してみてください。

Do While ie.Busy Or ie.ReadyState < READYSTATE_COMPLETE
  DoEvents: Sleep 200 '200ms停止
Loop

DoEvents

Do While ie.Busy or ie.document.readyState <> "complete"
  DoEvents: Sleep 200 '200ms停止
Loop