如何将Excel筛选后的单元格区域存入数组并写入其他工作簿？

核心思路 #

筛选后的可见区域可能由多个不连续的单元格块组成（通过Areas属性获取），我们需要遍历这些块，将数据整合到同一个数组中，再批量写入目标工作簿——这种方式比逐个单元格操作效率高得多。

完整代码实现 #

Sub StoreFilteredRangeInArray()
    Dim rData As Range, rFiltered As Range, rArea As Range
    Dim myArray() As Variant
    Dim totalRows As Long, currentRow As Long, colCount As Long
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    
    ' 处理源工作表（Sheet1）
    With ThisWorkbook.Sheets("Sheet1")
        ' 定义包含表头的数据区域
        Set rData = .Range("A1").CurrentRegion
        colCount = rData.Columns.Count
        
        ' 应用筛选（示例为第1列非空，可按需调整）
        rData.AutoFilter Field:=1, Criteria1:="<>"
        
        ' 获取筛选后的可见数据区域（排除表头）
        On Error Resume Next ' 处理筛选后无数据的情况
        Set rFiltered = rData.Offset(1, 0).Resize(rData.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not rFiltered Is Nothing Then
            ' 统计筛选后数据的总行数
            totalRows = 0
            For Each rArea In rFiltered.Areas
                totalRows = totalRows + rArea.Rows.Count
            Next rArea
            
            ' 初始化数组：行数为总筛选行数，列数与源数据一致
            ReDim myArray(1 To totalRows, 1 To colCount)
            
            ' 遍历每个不连续区域，将数据存入数组
            currentRow = 0
            For Each rArea In rFiltered.Areas
                Dim areaData As Variant
                ' 批量读取当前区域数据到临时数组
                areaData = rArea.Value
                
                ' 将临时数组数据复制到目标数组
                Dim i As Long, j As Long
                For i = 1 To UBound(areaData, 1)
                    currentRow = currentRow + 1
                    For j = 1 To UBound(areaData, 2)
                        myArray(currentRow, j) = areaData(i, j)
                    Next j
                Next i
            Next rArea
            
            ' 将数组写入目标工作簿的Sheet2（从A1开始）
            ' 若目标工作簿未打开，可替换为Workbooks.Open("文件路径")
            Set targetWB = Workbooks("目标工作簿名称.xlsx") ' 替换为实际文件名
            Set targetWS = targetWB.Sheets("Sheet2")
            
            ' 清空目标区域原有数据（可选）
            targetWS.Cells.Clear
            
            ' 批量写入数组数据
            targetWS.Range("A1").Resize(totalRows, colCount).Value = myArray
        Else
            MsgBox "筛选后无有效数据！"
        End If
        
        ' 关闭筛选（可选，按需保留筛选状态）
        .AutoFilterMode = False
    End With
End Sub

关键部分说明 #

1. 遍历筛选区域存入数组

   • 用rFiltered.Areas获取所有不连续的可见区块，逐个遍历
   • 先统计总行数再初始化数组，避免多次调整数组大小浪费资源
   • 每个区块用areaData = rArea.Value批量读取数据，比逐个单元格读取效率提升明显

2. 写入目标工作簿

   • 需替换代码中的目标工作簿名称.xlsx为实际文件名，若文件未打开，可使用Workbooks.Open("文件完整路径")打开
   • 用Range.Resize(totalRows, colCount).Value = myArray批量写入数组，这是VBA中写入数据的最优方式
   • 可选清空目标区域原有数据，防止新旧数据混杂

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