需求：编写VBA宏实现筛选结果（从第2行起）跨工作表粘贴

原代码的问题分析 #

• 硬编码的单元格范围$A$1:$U$419655无法适配数据源更新后的行/列变化
• 依赖ActiveSheet和Select操作容易因工作表切换、焦点变化导致运行错误，且执行效率低下
• 直接复制UsedRange.Offset(1,0)会包含筛选后的隐藏行，无法准确识别有效数据范围

优化后的自适应代码 #

Sub CopyFilteredData()
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim srcRange As Range
    Dim lastRow As Long
    Dim lastCol As Long
    
    ' 指定数据源工作表和目标工作表（根据实际名称修改）
    Set srcSheet = ThisWorkbook.Worksheets("数据源工作表名称") ' 替换成你的数据源表名
    Set destSheet = ThisWorkbook.Worksheets("HEX Acima")
    
    ' 清除目标工作表A2开始的旧数据
    destSheet.Range("A2", destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp)).EntireRow.Clear
    
    On Error Resume Next
    ' 取消现有筛选（避免因已筛选状态导致错误）
    srcSheet.ShowAllData
    On Error GoTo 0
    
    ' 动态获取数据源的最后一行和最后一列
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
    lastCol = srcSheet.Cells(1, srcSheet.Columns.Count).End(xlToLeft).Column
    
    ' 定义完整数据范围（包含表头）
    Set srcRange = srcSheet.Range(srcSheet.Cells(1, 1), srcSheet.Cells(lastRow, lastCol))
    
    ' 应用筛选：第18列，条件为"1"
    srcRange.AutoFilter Field:=18, Criteria1:="1"
    
    ' 复制筛选后的可见数据（从第2行开始，跳过表头）
    On Error Resume Next
    srcRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
    If Err.Number = 0 Then
        ' 粘贴为值到目标工作表A2
        destSheet.Range("A2").PasteSpecial Paste:=xlPasteValues
    Else
        MsgBox "没有符合条件的筛选结果"
    End If
    On Error GoTo 0
    
    ' 取消筛选
    srcSheet.AutoFilterMode = False
    
    ' 清除剪贴板
    Application.CutCopyMode = False
End Sub

关键优化点 #

• 动态数据范围：通过lastRow和lastCol自动获取数据源的边界，适配数据更新
• 避免Select操作：直接引用工作表和单元格范围，提升代码稳定性和效率
• 处理边界情况：
  • 先清除目标区域旧数据
  • 捕获ShowAllData的错误（若原本无筛选）
  • 检测是否有筛选结果，避免空复制
• 仅复制可见单元格：用SpecialCells(xlCellTypeVisible)确保只复制筛选后的有效数据

使用说明 #

1. 将代码中的"数据源工作表名称"替换为你实际的数据源工作表名称
2. 若筛选条件或目标位置需要调整，修改对应参数即可

内容的提问来源于stack exchange，提问作者Giulia Lopes Ramos Moura