将带公式的二维区域转一维数组并排除指定值后粘贴至指定工作表

完整可运行代码 #

Sub TwoD_ArrayTo_1D_Array()
    Dim rg As Range
    ' 定位数据源：Sheet1中A2起始的当前连续区域
    Set rg = Sheet1.Range("A2").CurrentRegion
    
    Dim arr As Variant, arr1D() As Variant
    arr = rg.Value ' 将区域数据存入二维数组，提升操作效率
    
    Dim i As Long, j As Long, k As Long
    k = 0 ' 一维数组的索引计数器
    
    ' 遍历二维数组，筛选排除"No DATA"的元素
    For i = 1 To rg.Rows.Count
        For j = 1 To rg.Columns.Count
            If arr(i, j) <> "No DATA" Then
                k = k + 1
                ReDim Preserve arr1D(1 To k) ' 动态扩展一维数组，保留已有数据
                arr1D(k) = arr(i, j)
            End If
        Next j
    Next i
    
    ' 将筛选后的一维数组批量写入Result工作表B2及以下区域
    If k > 0 Then ' 避免空数组导致的写入错误
        Result.Range("B2").Resize(k, 1).Value = Application.Transpose(arr1D)
    End If
End Sub

关键修正与优化说明 #

• 移除冗余操作：删掉原代码中不必要的Select语句，VBA中直接通过Set定义区域更高效稳定。
• 数组操作纠错：
  • 从区域读取的二维数组arr是值数组，直接用arr(i,j)访问元素即可，原代码的.Value属性属于错误用法。
  • 修正了一维数组的索引逻辑，通过计数器k动态扩展数组，避免原代码中未初始化循环变量导致的遍历失败。
• 筛选逻辑简化：去掉原代码的GoTo跳转，直接通过条件判断跳过目标值，代码可读性更强。
• 写入效率提升：使用Resize配合Transpose批量写入数组，替代循环逐个赋值的低效方式，数据量越大优势越明显。
• 边界安全判断：增加k>0的判断，防止无有效数据时执行写入操作引发错误。

原代码核心问题总结 #

1. 循环变量未初始化：For i = i To ...中i无初始值，导致循环无法正常执行。
2. 数组访问语法错误：二维值数组不需要.Value属性，原代码会触发运行时错误。
3. 一维数组赋值错误：粘贴时误用二维数组的访问方式arr1D(iRw,1)，实际应为一维数组的arr1D(iRw)。
4. 写入效率低下：循环逐个写入单元格的方式远不如批量数组写入高效。

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