VBA Excel抓取网页表格运行缓慢的优化方案咨询

你当前代码的核心性能瓶颈是逐单元格操作Excel对象，每一次对单元格的赋值都会触发Excel的界面重绘、事件响应、区域检查，200行16列的表格会产生3000+次独立IO操作，占总耗时的90%以上，再加上冗余的DOM遍历、未关闭Excel实时交互功能，进一步拖慢了运行速度。可通过以下方案优化，整体速度可提升10~50倍：

• 关闭Excel实时交互开销
  代码运行前临时关闭屏幕更新、自动公式重算、事件触发，所有操作完成后再恢复原有设置，可直接砍掉60%以上的无效系统开销。必须搭配错误捕获逻辑，避免代码中途报错导致设置无法恢复，影响Excel正常使用。
• 内存数组批量写入
  先在内存中定义和目标表格行列数匹配的二维数组，遍历DOM节点时将表格内容存入数组，所有数据读取完成后，一次性将整个数组赋值给工作表对应单元格区域，将数千次单元格IO操作压缩为1次，是提升速度最核心的手段。
• 精简DOM遍历逻辑
  不需要遍历页面所有table标签再匹配ID，直接调用getElementById("table_details")即可直接定位目标表格；也不需要循环遍历table的子节点查找TBODY，直接取表格对象的tBodies(0)属性就能拿到表体节点，省掉多层循环判断的开销。
• 优化IE等待逻辑
  原有空循环等待会无意义占用CPU，也容易出现DOM未完全渲染就开始抓取的问题，可在等待循环中加入短间隔等待、让出CPU时间片，同时增加目标表格存在性判断，确认表格完全加载后再执行抓取逻辑。

Sub FetchPressQualityHoldTable()
    Dim HTMLTable As MSHTML.IHTMLElement
    Dim TableSection As MSHTML.IHTMLElement
    Dim TableRow As MSHTML.IHTMLElement
    Dim TableCell As MSHTML.IHTMLElement
    Dim ws As Worksheet
    Dim row As Long, col As Long, maxRow As Long, maxCol As Long
    Dim dataArr As Variant
    ' 保存Excel原有配置
    Dim originalCalc As XlCalculation
    Dim originalScreenUpdate As Boolean
    Dim originalEvent As Boolean
    
    Set ws = Workbooks("Zautomatyzowany raport produkcyjny.xlsm").Worksheets("PressQualityHold")
    originalScreenUpdate = Application.ScreenUpdating
    originalCalc = Application.Calculation
    originalEvent = Application.EnableEvents
    
    On Error GoTo ErrorCatch
    ' 临时关闭拖慢速度的功能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 等待IE加载完成
    Do While IE.readyState <> READYSTATE_COMPLETE Or IE.Busy
        DoEvents
        Application.Wait Now + TimeValue("0:00:01")
    Loop
    ' 确认目标表格已渲染
    Do While HTMLDoc.getElementById("table_details") Is Nothing
        DoEvents
        Application.Wait Now + TimeValue("0:00:00.5")
    Loop
    
    ws.Cells.Clear
    ' 直接定位目标表格与表体，跳过冗余遍历
    Set HTMLTable = HTMLDoc.getElementById("table_details")
    Set TableSection = HTMLTable.tBodies(0)
    
    ' 初始化内存数组
    maxRow = TableSection.Children.Length
    maxCol = TableSection.Children(0).Children.Length
    ReDim dataArr(1 To maxRow, 1 To maxCol)
    
    ' 读取表格数据到内存数组
    row = 1
    For Each TableRow In TableSection.Children
        col = 1
        For Each TableCell In TableRow.Children
            dataArr(row, col) = TableCell.innerText
            col = col + 1
        Next TableCell
        row = row + 1
    Next TableRow
    
    ' 一次性批量写入工作表
    ws.Range("A1").Resize(maxRow, maxCol).Value = dataArr
    
    ' 释放IE对象
    IE.Quit
    Set IE = Nothing

RestoreSetting:
    ' 恢复Excel原有配置
    Application.ScreenUpdating = originalScreenUpdate
    Application.Calculation = originalCalc
    Application.EnableEvents = originalEvent
    Exit Sub
ErrorCatch:
    MsgBox "抓取运行出错：" & Err.Description, vbExclamation
    Resume RestoreSetting
End Sub

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