VBA直接为表格DataBodyRange赋值无效果，如何高效复制表格数据？

• 原代码未显式指定Value属性：VBA中直接对Range对象变量赋值默认操作的是对象引用而非单元格值，跨表场景下不会触发隐式的值写入，因此无报错也无写入效果
• 未做行列匹配校验：如果目标表Table1的DataBodyRange行数、列数与源表Table2的范围不一致，会出现写入失败、数据截断的问题；如果目标表原本无数据行，DataBodyRange本身为Nothing，也无法写入数据

批量数组赋值是表格场景下效率最高的方案，比复制粘贴快5~10倍，实现前先关闭Excel的交互、计算配置避免不必要的性能消耗，完整代码如下：

Sub 批量复制表格数据()
    ' 预存原配置，后续恢复
    Dim preScreenUpdating As Boolean, preEnableEvents As Boolean, preCalculation As XlCalculation
    preScreenUpdating = Application.ScreenUpdating
    preEnableEvents = Application.EnableEvents
    preCalculation = Application.Calculation
    
    ' 关闭耗时配置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 定义表格对象
    Dim sourceTable As ListObject, targetTable As ListObject
    Set sourceTable = ThisWorkbook.Sheets(2).ListObjects("Table2")
    Set targetTable = ThisWorkbook.Sheets(1).ListObjects("Table1")
    
    ' 源表无数据直接退出
    If sourceTable.DataBodyRange Is Nothing Then GoTo 恢复配置
    
    ' 读取源数据到数组，仅读一次IO
    Dim dataArr As Variant
    dataArr = sourceTable.DataBodyRange.Value
    Dim rowCount As Long, colCount As Long
    rowCount = UBound(dataArr, 1)
    colCount = UBound(dataArr, 2)
    
    ' 清空目标表现有数据
    If Not targetTable.DataBodyRange Is Nothing Then
        targetTable.DataBodyRange.Delete
    End If
    
    ' 给目标表新增对应行数的空行
    targetTable.ListRows.Add Count:=rowCount
    
    ' 批量写入数组，仅写一次IO
    targetTable.DataBodyRange.Value = dataArr
    
恢复配置:
    ' 恢复原配置
    Application.ScreenUpdating = preScreenUpdating
    Application.EnableEvents = preEnableEvents
    Application.Calculation = preCalculation
End Sub

• 需保证源表和目标表的列顺序、列数完全一致，否则会出现数据错位
• 如果目标表存在固定公式列，可以在写入完成后单独给公式列做批量填充，无需修改上述赋值逻辑
• 如果数据量超过10万行，可以额外关闭targetTable.ShowHeaders和targetTable.ShowTotals临时隐藏表头表尾，写入完成后再恢复，可进一步提升速度

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