如何在VBA中将多个不连续区域赋值给数组以提升批量数据复制效率

问题原因 #

VBA 不支持直接将Union生成的非连续区域赋值为包含所有子区域内容的多维数组，直接赋值时只会提取第一个子区域（也就是你代码里的A列）的数据，所以最终只能得到单列数组。

解决方案 #

推荐用纯数组拼接的方案，全程在内存操作，对上百个工作表的批量处理场景性能提升最明显：

Sub CopyData()
    Dim LastR As Long
    Dim colA As Variant, colC As Variant, colH As Variant
    Dim dataArr As Variant
    Dim i As Long
    
    With SourceWS
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        ' 单独读取每一列到数组
        colA = .Range("A8:A" & LastR).Value
        colC = .Range("C8:C" & LastR).Value
        colH = .Range("H8:H" & LastR).Value
    End With
    
    ' 初始化目标数组：行数同单个数组，列数3
    ReDim dataArr(1 To UBound(colA, 1), 1 To 3)
    ' 逐行拼接内容
    For i = 1 To UBound(colA, 1)
        dataArr(i, 1) = colA(i, 1)
        dataArr(i, 2) = colC(i, 1)
        dataArr(i, 3) = colH(i, 1)
    Next
    
    ' 一次性写入目标表
    DestWS.Range("A1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub

额外优化提示 #

• 如果需要扩展更多列，只要对应增加单列读取的变量、调整目标数组的列数、在循环里加赋值逻辑即可。
• 批量处理多工作表时，可以在代码开头加Application.ScreenUpdating = False、Application.EnableEvents = False，处理完成后再恢复原值，能进一步提升运行速度。

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