如何通过VBA将Excel筛选区域复制粘贴到同工作表的另一筛选区域

原代码核心问题 #

• 变量未声明完整：Source 变量未提前定义，开启强制声明规则时会直接报错
• 逻辑冗余冲突：筛选完FCDP 21的可见单元格后，又通过输入框让用户选择源区域，和预设取筛选结果的需求冲突
• 可见行判断逻辑不稳定：通过行高判断是否为筛选可见行，容易受手动调整行高的场景影响，直接调用SpecialCells(xlCellTypeVisible)更可靠
• 剪贴板操作效率低：大文件场景下用复制粘贴容易触发卡顿，直接单元格赋值效率更高，也不会出现粘贴失效的问题
• 目标区域匹配逻辑错误：遍历过程中修改destination_cells的范围，容易出现源数据和目标行数量不匹配、越界的问题

修复后的可运行代码 #

Sub 筛选复制粘贴可见行()
    Dim visible_source_cells As Range
    Dim destination_cells As Range
    Dim source_arr As Variant
    Dim i As Long, target_row As Range
    
    ' 第一步：筛选FCDP 21并提取可见单元格值
    With Range("A2:R667")
        .AutoFilter Field:=5, Criteria1:="FCDP 21"
        ' 直接获取筛选后的可见单元格，不需要手动选择
        Set visible_source_cells = .SpecialCells(xlCellTypeVisible)
        ' 把源值存入数组，避免依赖剪贴板
        source_arr = visible_source_cells.Value
        ' 临时清除字段筛选避免影响后续操作
        .AutoFilter Field:=5
    End With
    
    ' 第二步：筛选MSR M-1 21获取目标区域
    With Range("A2:R667")
        .AutoFilter Field:=5, Criteria1:="MSR M-1 21"
        ' 直接获取目标可见区域
        Set destination_cells = .SpecialCells(xlCellTypeVisible)
    End With
    
    ' 第三步：逐行匹配赋值
    i = 1
    For Each target_row In destination_cells.Rows
        ' 源数据填充完成后自动终止
        If i > UBound(source_arr, 1) Then Exit For
        target_row.Value = Application.Index(source_arr, i, 0)
        i = i + 1
    Next target_row
    
    ' 清理：可自行选择是否保留最终筛选状态，不需要关闭筛选可注释下一行
    Range("A2:R667").AutoFilter Field:=5
    Application.CutCopyMode = False
End Sub

使用注意事项 #

• 如果数据范围不是固定的A2:R667，可以把硬编码范围改成动态获取，比如用ActiveSheet.UsedRange适配大文件的范围变化
• 当前代码默认仅粘贴数值，需要保留单元格格式的话可以把赋值逻辑替换为带格式的复制粘贴规则
• 运行前建议先备份原文件，避免数据误覆盖

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