提升IE表格导入速度咨询：大表格数据迁移优化方案

嘿，我完全懂你面对30×5000规模的表格，用For循环逐个单元格读取慢到抓狂的感觉！直接复制粘贴绝对是可行的，而且还有几个更高效的批量处理方案，咱们一个个来拆解：

方案1：直接复制粘贴网页表格（最快最省心） #

这个方法直接利用系统剪贴板完成批量传输，完全避开循环，速度能提升N倍。核心思路是选中网页里的表格，执行复制，再粘贴到Excel工作表：

Sub CopyPasteTableFromIE()
    Dim doc As Object
    Dim hTable As Object
    Set doc = ie.Document
    
    ' 获取页面中的第一个表格（如果是其他表格，调整索引即可，比如(1)是第二个）
    Set hTable = doc.GetElementsByTagName("table")(0)
    
    ' 选中表格并复制
    hTable.Select
    doc.execCommand "Copy"
    
    ' 粘贴到指定工作表的起始位置
    ThisWorkbook.Sheets("你的工作表名").Range("A1").PasteSpecial xlPasteAll
    
    ' 清理剪贴板（可选）
    Application.CutCopyMode = False
End Sub

注意：如果页面有多个表格，记得调整GetElementsByTagName("table")的索引值，确保选中的是你需要的那个表格。

方案2：用QueryTable直接导入HTML表格 #

这个方法不需要依赖剪贴板，直接让Excel从网页抓取指定表格数据，也是批量操作，速度同样很快：

Sub ImportTableWithQueryTable()
    Dim qt As QueryTable
    Dim targetSheet As Worksheet
    
    Set targetSheet = ThisWorkbook.Sheets("你的工作表名")
    
    ' 创建QueryTable，导入当前IE页面的表格
    Set qt = targetSheet.QueryTables.Add( _
        Connection:="URL;" & ie.LocationURL, _
        Destination:=targetSheet.Range("A1"))
    
    ' 指定只导入网页中的表格，这里的"1"代表第一个表格，多个表格可以用逗号分隔（比如"1,3"）
    qt.WebSelectionType = xlSpecifiedTables
    qt.WebTables = "1"
    
    ' 执行刷新（导入数据）
    qt.Refresh BackgroundQuery:=False
    
    ' 如果不需要保留查询连接，可以删除QueryTable
    qt.Delete
End Sub

方案3：优化原循环（必须用循环时的最优解） #

如果因为某些原因不能用前两种方法，那优化循环的关键是先把数据读到内存数组，再一次性写入工作表——因为逐个单元格写入会频繁触发Excel的界面刷新和数据交互，而数组操作完全在内存中进行，速度会快很多：

Sub OptimizedLoopExtract()
    Dim doc As Object
    Dim hTable As Object, hRows As Object, hCells As Object
    Dim rowCount As Long, colCount As Long
    Dim dataArr() As Variant
    Dim i As Long, j As Long
    
    Set doc = ie.Document
    Set hTable = doc.GetElementsByTagName("table")(0)
    Set hRows = hTable.GetElementsByTagName("tr")
    
    ' 获取表格的行和列数
    rowCount = hRows.Length
    colCount = hRows(0).GetElementsByTagName("td").Length
    
    ' 初始化数组
    ReDim dataArr(1 To rowCount, 1 To colCount)
    
    ' 循环填充数组（内存操作，速度快）
    For i = 0 To rowCount - 1
        Set hCells = hRows(i).GetElementsByTagName("td")
        For j = 0 To colCount - 1
            dataArr(i + 1, j + 1) = hCells(j).innerText
        Next j
    Next i
    
    ' 一次性写入工作表
    ThisWorkbook.Sheets("你的工作表名").Range("A1").Resize(rowCount, colCount).Value = dataArr
End Sub

总结 #

优先推荐方案1和方案2，这两个都是批量处理，能把原本1分钟的操作压缩到几秒内完成；如果必须用循环，方案3也能比原代码快至少5-10倍。

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