【Excel VBA×Selenium】無限スクロールのページからデータを取得する方法｜最下部まで自動スクロール

Option Explicit

Sub GetInfiniteScrollData()

    Dim driver As New Selenium.ChromeDriver
    Dim items As Selenium.WebElements
    Dim item As Selenium.WebElement
    Dim ws As Worksheet

    Dim beforeCount As Long
    Dim afterCount As Long
    Dim stopCount As Long
    Dim scrollCount As Long
    Dim waitCount As Long
    Dim outputRow As Long

    On Error GoTo ErrorHandler

    '========================================
    ' 出力先のワークシートを設定する
    '========================================
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    ' 以前の取得結果を削除する
    ws.Range("A:B").ClearContents

    ' 見出しを設定する
    ws.Cells(1, 1).Value = "名言"
    ws.Cells(1, 2).Value = "著者"

    '========================================
    ' Chromeを起動する
    '========================================
    driver.Start "chrome"

    '========================================
    ' 対象のWebページを開く
    '========================================
    driver.Get "https://quotes.toscrape.com/scroll"

    '========================================
    ' 最初のデータが読み込まれるまで待機する
    '========================================
    For waitCount = 1 To 20

        ' 現在表示されているデータ件数を取得する
        beforeCount = driver.FindElementsByCss(".quote").Count

        ' 1件以上取得できれば待機処理を終了する
        If beforeCount > 0 Then Exit For

        ' 500ミリ秒待機する
        driver.Wait 500

    Next waitCount

    ' データを取得できなかった場合は終了する
    If beforeCount = 0 Then

        MsgBox "データを取得できませんでした。", vbExclamation
        GoTo ExitProc

    End If

    '========================================
    ' 最下部まで自動スクロールする
    '========================================
    For scrollCount = 1 To 40

        ' ページの最下部までスクロールする
        driver.ExecuteScript _
            "window.scrollTo(0, document.documentElement.scrollHeight);"

        '========================================
        ' 新しいデータの読み込みを待機する
        '========================================
        afterCount = beforeCount

        For waitCount = 1 To 10

            ' 500ミリ秒待機する
            driver.Wait 500

            ' スクロール後のデータ件数を取得する
            afterCount = driver.FindElementsByCss(".quote").Count

            ' 件数が増えた場合は待機を終了する
            If afterCount > beforeCount Then Exit For

        Next waitCount

        '========================================
        ' 取得件数を確認する
        '========================================
        Debug.Print "スクロール回数：" & scrollCount & _
                    " / 取得件数：" & afterCount

        '========================================
        ' スクロール前後の件数を比較する
        '========================================
        If afterCount > beforeCount Then

            ' 件数が増えた場合はカウンターを初期化する
            stopCount = 0

        Else

            ' 件数が増えなかった場合は加算する
            stopCount = stopCount + 1

        End If

        ' 次回比較するための件数を更新する
        beforeCount = afterCount

        '========================================
        ' スクロール処理の終了判定
        '========================================
        ' 3回連続で件数が増えなければ終了する
        If stopCount >= 3 Then Exit For

    Next scrollCount

    '========================================
    ' 読み込んだデータを取得する
    '========================================
    Set items = driver.FindElementsByCss(".quote")

    ' Excelへの出力開始行を設定する
    outputRow = 2

    '========================================
    ' 取得したデータをExcelへ出力する
    '========================================
    For Each item In items

        ' 名言をA列へ出力する
        ws.Cells(outputRow, 1).Value = _
            item.FindElementByCss(".text").Text

        ' 著者をB列へ出力する
        ws.Cells(outputRow, 2).Value = _
            item.FindElementByCss(".author").Text

        ' 次の行へ移動する
        outputRow = outputRow + 1

    Next item

    '========================================
    ' 処理完了を通知する
    '========================================
    If stopCount >= 3 Then

        MsgBox items.Count & "件のデータを取得しました。", _
               vbInformation, "取得完了"

    Else

        MsgBox items.Count & "件を取得しましたが、" & _
               "最大スクロール回数に達しました。", _
               vbExclamation, "取得結果の確認"

    End If

ExitProc:

    ' Chromeを終了する
    On Error Resume Next
    driver.Quit
    On Error GoTo 0
    Exit Sub

ErrorHandler:

    ' エラーが発生した場合は内容を表示する
    MsgBox "エラーが発生しました。" & vbCrLf & _
           Err.Description, vbExclamation

    Resume ExitProc

End Sub

beforeCount = driver.FindElementsByCss(".quote").Count

driver.ExecuteScript _
    "window.scrollTo(0, document.documentElement.scrollHeight);"

For waitCount = 1 To 10

    ' 500ミリ秒待機する
    driver.Wait 500

    ' 現在のデータ件数を取得する
    afterCount = driver.FindElementsByCss(".quote").Count

    ' 件数が増えた場合は待機を終了する
    If afterCount > beforeCount Then Exit For

Next waitCount

If afterCount > beforeCount Then

    ' 件数が増えた場合は初期化する
    stopCount = 0

Else

    ' 件数が増えなかった場合は加算する
    stopCount = stopCount + 1

End If

If stopCount >= 3 Then Exit For