VBA网页爬虫无法抓取全部PlayStation游戏数据问题求助

问题背景 #

使用VBA通过IE抓取指定PSN用户的游戏数据（共69款），但仅能获取前50款。尝试过强制滚动到页面底部、添加等待计时器，均未解决问题。原代码如下：

Sub scrape_quotes()
    Set browser = CreateObject("InternetExplorer.Application")
    
    'Dim browser    As InternetExplorer
    Dim Games       As Object
    Dim Game        As Object
    Dim Num         As Long
    Dim DateLastPlayed As Object
    Dim PlatformType As Object
    Dim BronzeNum As Object
    Dim SilverNum As Object
    Dim GoldNum As Object
    
    MsgBox "Please wait, this may take a few minutes..." & vbNewLine & "Pres OK To Continue", vbInformation, "Game Tracker"
    Application.StatusBar = "Scraping Data. Please wait..."
    
    ' Assigns a cell for the URL
    Dim URL         As String
    URL = ThisWorkbook.Sheets("Scraper").Range("B6").Value
    If Len(URL) = 0 Then Exit Sub
    
    ' Opens "invisible" browser and remains until all data is loaded
    
    'Set browser = New InternetExplorer
    browser.Visible = True
    browser.Navigate URL
    Do While browser.readyState <> 4 Or browser.Busy: DoEvents: Loop
        browser.Document.parentWindow.scroll 0&, 20000&
        
        On Error GoTo ErrHandler
        
        ' Looks for data in the "box" element on website
        Set Games = browser.Document.getElementsByClassName("box")
        Dim GameName As String, Hoursplayed As String
        
        ' Looks for data in the "lastplayed" element on website
        Set DateLastPlayed = browser.Document.getElementsByClassName("lastplayed")
        Dim Lastplayed As String
        
        ' Looks for data in the "platforms" element on website
        Set PlatformType = browser.Document.getElementsByClassName("platforms")
        Dim Platform As String
        
        ' Looks for data in the "bronze" element on website
        Set BronzeNum = browser.Document.getElementsByClassName("bronze")
        Dim Bronze As String
        
        ' Looks for data in the "silver" element on website
        Set SilverNum = browser.Document.getElementsByClassName("silver")
        Dim Silver As String
        
        ' Looks for data in the "gold" element on website
        Set GoldNum = browser.Document.getElementsByClassName("gold")
        Dim Gold As String
        
        ' Assigns which sheet to parse data do
        Dim WS      As Worksheet
        Set WS = ThisWorkbook.Sheets("Games List")
        
        ' Assigns each column used for each category
        Application.ScreenUpdating = False
        For Each Game In Games
            CleanData Game.innerText, GameName, Hoursplayed, Lastplayed, Platform, Bronze, Silver, Gold
            If Len(GameName) Then
                Num = Num + 1
                WS.Cells(1 + Num, 1).Value = GameName
                WS.Cells(1 + Num, 2).Value = Hoursplayed
                WS.Cells(1 + Num, 4).Value = Platform
                
            End If
            
            GameName = "": Hoursplayed = ""
            
        Next
        
        'New code starts here.
        Num = 0
        For Each Line In DateLastPlayed
            If Len(Line) Then
                Num = Num + 1
                WS.Cells(1 + Num, 3).Value = Line.innerText
            End If
            
        Next
        
        Num = 0
        For Each Line In PlatformType
            If Len(Line) Then
                Num = Num + 1
                WS.Cells(1 + Num, 4).Value = Line.innerText
            End If
            
        Next
        
        Num = 0
        For Each Line In BronzeNum
            If Len(Line) Then
                Num = Num + 1
                WS.Cells(1 + Num, 5).Value = Line.innerText
            End If
            
        Next
        
        Num = 0
        For Each Line In SilverNum
            If Len(Line) Then
                Num = Num + 1
                WS.Cells(1 + Num, 6).Value = Line.innerText
            End If
            
        Next
        
        Num = 0
        For Each Line In GoldNum
            If Len(Line) Then
                Num = Num + 1
                WS.Cells(1 + Num, 7).Value = Line.innerText
            End If
            
        Next
        
ErrHandler:
        If Err.Number = 0 Then Debug.Print Err.Number & vbNewLine & Err.Description
        Application.ScreenUpdating = True
        browser.Quit
        
        Set browser = Nothing
        MsgBox "Game Data Has Been Scraped!", vbExclamation, "Game Tracker"
        Application.StatusBar = False
        Sheets("Games List").Activate
        
    End Sub

问题原因 #

该网站采用懒加载机制：仅当用户滚动到页面底部时，才会加载更多游戏数据。原代码仅执行一次滚动，无法触发全部后续内容的加载，导致只能抓取初始加载的50款游戏。

解决方案 #

修改代码，实现循环滚动+等待加载，直到页面不再新增内容。关键改动点：

1. 循环滚动到页面底部，每次滚动后等待内容加载
2. 对比滚动前后的游戏数量，确认是否加载完成
3. 优化元素获取时机，确保所有内容加载完毕后再抓取

修改后的完整代码：

Sub scrape_quotes()
    Dim browser As Object
    Set browser = CreateObject("InternetExplorer.Application")
    
    Dim Games As Object
    Dim Game As Object
    Dim Num As Long
    Dim DateLastPlayed As Object
    Dim PlatformType As Object
    Dim BronzeNum As Object
    Dim SilverNum As Object
    Dim GoldNum As Object
    
    Dim URL As String
    Dim WS As Worksheet
    Dim prevGameCount As Long
    Dim currentGameCount As Long
    Dim scrollWaitTime As Long
    
    ' 设置滚动后等待加载的时间（毫秒），可根据网速调整
    scrollWaitTime = 2000
    
    MsgBox "请稍等，此过程可能需要几分钟..." & vbNewLine & "点击确定继续", vbInformation, "游戏追踪器"
    Application.StatusBar = "正在抓取数据，请稍候..."
    
    ' 获取URL
    URL = ThisWorkbook.Sheets("Scraper").Range("B6").Value
    If Len(URL) = 0 Then Exit Sub
    
    ' 初始化浏览器
    browser.Visible = True
    browser.Navigate URL
    
    ' 等待页面初始加载完成
    Do While browser.readyState <> 4 Or browser.Busy
        DoEvents
    Loop
    
    ' 循环滚动加载所有内容
    prevGameCount = 0
    Do
        ' 滚动到页面底部
        browser.Document.parentWindow.scroll 0&, browser.Document.body.scrollHeight
        
        ' 等待内容加载
        Application.Wait Now + TimeSerial(0, 0, scrollWaitTime / 1000)
        
        ' 等待浏览器状态稳定
        Do While browser.readyState <> 4 Or browser.Busy
            DoEvents
        Loop
        
        ' 获取当前游戏数量
        Set Games = browser.Document.getElementsByClassName("box")
        currentGameCount = Games.Count
        
        ' 如果数量不再增加，说明加载完成
        If currentGameCount = prevGameCount Then
            Exit Do
        End If
        
        prevGameCount = currentGameCount
    Loop
    
    On Error GoTo ErrHandler
    
    ' 获取所有元素
    Set DateLastPlayed = browser.Document.getElementsByClassName("lastplayed")
    Set PlatformType = browser.Document.getElementsByClassName("platforms")
    Set BronzeNum = browser.Document.getElementsByClassName("bronze")
    Set SilverNum = browser.Document.getElementsByClassName("silver")
    Set GoldNum = browser.Document.getElementsByClassName("gold")
    
    ' 准备输出工作表
    Set WS = ThisWorkbook.Sheets("Games List")
    Application.ScreenUpdating = False
    
    ' 清空原有数据（可选，视需求调整）
    WS.Range("A2:G" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row).ClearContents
    
    ' 遍历游戏数据
    Num = 0
    Dim GameName As String, Hoursplayed As String, Lastplayed As String
    Dim Platform As String, Bronze As String, Silver As String, Gold As String
    
    For Each Game In Games
        CleanData Game.innerText, GameName, Hoursplayed, Lastplayed, Platform, Bronze, Silver, Gold
        If Len(GameName) Then
            Num = Num + 1
            WS.Cells(1 + Num, 1).Value = GameName
            WS.Cells(1 + Num, 2).Value = Hoursplayed
            WS.Cells(1 + Num, 3).Value = DateLastPlayed(Num - 1).innerText
            WS.Cells(1 + Num, 4).Value = PlatformType(Num - 1).innerText
            WS.Cells(1 + Num, 5).Value = BronzeNum(Num - 1).innerText
            WS.Cells(1 + Num, 6).Value = SilverNum(Num - 1).innerText
            WS.Cells(1 + Num, 7).Value = GoldNum(Num - 1).innerText
        End If
        
        GameName = "": Hoursplayed = ""
    Next
    
ErrHandler:
    If Err.Number <> 0 Then
        Debug.Print "错误代码: " & Err.Number & vbNewLine & "错误描述: " & Err.Description
        MsgBox "抓取过程中发生错误: " & Err.Description, vbCritical, "错误提示"
    End If
    
    Application.ScreenUpdating = True
    browser.Quit
    Set browser = Nothing
    
    MsgBox "游戏数据抓取完成！共获取 " & Num & " 款游戏", vbExclamation, "游戏追踪器"
    Application.StatusBar = False
    Sheets("Games List").Activate
End Sub

关键改动说明 #

• 循环滚动加载：通过对比滚动前后的游戏数量，确保所有内容加载完毕
• 等待机制：添加固定等待时间和浏览器状态检查，避免未加载完成就开始抓取
• 优化数据写入：将所有数据的写入合并到一个循环中，避免多循环导致的索引错位问题
• 错误处理优化：增加错误提示，便于排查问题

内容的提问来源于stack exchange，提问作者Vishera