Excel-VBA筛选后复制列A异常显示全部行问题求助

问题原因 #

核心问题是直接复制整列而非筛选后的可见单元格：

• 原代码用Columns("A")复制整列，即使源列通过AutoFilter隐藏了部分行，整列复制仍会包含所有行（包括隐藏行）。
• 前几次运行看似正常，大概率是目标工作簿Export_LI.xlsx的A列原有数据刚好被覆盖为可见行内容，多次运行后，源工作簿隐藏行的A列数据被写入目标列，导致显示全部4行。
• B、C列看似正常是巧合（比如隐藏行的B、C列无数据），但原代码同样存在复制隐藏行的风险。

修正后的代码 #

Sub Transfer()
    Dim wsSource As Worksheet
    Dim loSource As ListObject
    Dim wsTarget As Worksheet
    Dim wbTarget As Workbook
    Dim visibleRange As Range
    
    ' 明确引用源工作簿和工作表，避免依赖Active状态
    Set wsSource = Workbooks("Test.xlsm").Worksheets(1)
    Set loSource = wsSource.ListObjects("Tabel1")
    
    ' 清除原有筛选（避免多次运行后筛选状态混乱）
    loSource.Range.AutoFilter
    
    ' 重新应用筛选：E列包含"Fiets"
    loSource.Range.AutoFilter Field:=5, Criteria1:="=*Fiets*", Operator:=xlAnd
    
    ' 获取筛选后的可见数据区域（仅A、B、C列）
    On Error Resume Next ' 处理无匹配结果的情况
    Set visibleRange = loSource.DataBodyRange.SpecialCells(xlCellTypeVisible).Resize(, 3)
    On Error GoTo 0
    
    ' 打开目标工作簿并引用工作表
    Set wbTarget = Workbooks.Open("C:\Users\raymo\Documents\AB\Export_LI.xlsx")
    Set wsTarget = wbTarget.Worksheets(1)
    
    ' 清除目标区域原有数据
    wsTarget.Range("A:C").ClearContents
    
    ' 复制表头和筛选后的数据到目标工作表
    If Not visibleRange Is Nothing Then
        loSource.HeaderRowRange.Resize(, 3).Copy wsTarget.Range("A1") ' 复制表头
        visibleRange.Copy wsTarget.Range("A2") ' 复制筛选后的数据行
    End If
    
    ' 可选：关闭源工作表的筛选
    loSource.Range.AutoFilter
    
    ' 可选：保存并关闭目标工作簿（根据需求调整）
    wbTarget.Save
    wbTarget.Close
End Sub

关键改进点 #

• 明确对象引用：不再依赖ActiveSheet/ActiveWorkbook，避免工作簿切换导致的引用错误。
• 仅复制可见区域：用SpecialCells(xlCellTypeVisible)精准获取筛选后的匹配行，确保只复制需要的数据。
• 清理目标数据：复制前清除目标列旧数据，避免残留内容干扰结果。
• 容错处理：加入错误捕获，防止无筛选结果时代码报错。
• 分离表头与数据：确保表头和筛选数据的对应关系准确。

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