从筛选工作表复制结果行忽略空白，VBA宏触发1004错误求助

Hey there! 作为VBA新手碰到这种边界情况太正常了——当筛选后没有结果行时，代码硬复制空白区域肯定会炸出1004错误。我来帮你修复这个问题，顺便给你讲清楚为啥会出错～

问题根源 #

你原来的代码应该是直接尝试复制筛选后的可见区域，但如果筛选后只有表头、没有任何数据行，要么会生成一个无效的单元格范围（比如A2:Z1），要么SpecialCells(xlCellTypeVisible)找不到符合条件的单元格，直接触发1004运行时错误。

修复后的完整代码 #

我基于你提供的代码框架，添加了关键的判断逻辑，确保只有存在有效筛选数据时才执行复制：

Sub MergeDataFromWorkbooks()
    Dim wbk As Workbook
    Dim wbk1 As Workbook
    Set wbk1 = ThisWorkbook ' 汇总工作簿
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim destLastRow As Long
    Dim visibleDataRange As Range
    
    ' 打开文件选择对话框（可根据你的需求替换成固定路径逻辑）
    Dim filePicker As FileDialog
    Set filePicker = Application.FileDialog(msoFileDialogFilePicker)
    With filePicker
        .AllowMultiSelect = True
        .Filters.Add "Excel文件", "*.xlsx;*.xls"
        If .Show = -1 Then
            Dim selectedPath As Variant
            For Each selectedPath In .SelectedItems
                Set wbk = Workbooks.Open(selectedPath)
                
                For Each ws In wbk.Worksheets
                    ' --- 替换成你实际的筛选逻辑 ---
                    ws.Range("A1").AutoFilter Field:=1, Criteria1:="你的筛选条件"
                    
                    ' 获取当前工作表数据区域的最后一行（包含表头）
                    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                    
                    ' 第一步判断：至少要有表头之外的行才可能有数据
                    If lastRow > 1 Then
                        ' 捕获SpecialCells可能的错误（无可见数据时会报错）
                        On Error Resume Next
                        Set visibleDataRange = ws.Range("A2:Z" & lastRow).SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0 ' 恢复默认错误处理
                        
                        ' 第二步判断：确认存在可见的数据区域
                        If Not visibleDataRange Is Nothing Then
                            ' 找到汇总表的下一个空白行
                            destLastRow = wbk1.Sheets("汇总").Cells(wbk1.Sheets("汇总").Rows.Count, "A").End(xlUp).Row + 1
                            ' 复制粘贴值（避免格式干扰）
                            visibleDataRange.Copy
                            wbk1.Sheets("汇总").Range("A" & destLastRow).PasteSpecial xlPasteValues
                            Set visibleDataRange = Nothing ' 释放对象内存
                        End If
                    End If
                    
                    ' 关闭当前工作表的筛选（可选，避免修改原文件状态）
                    ws.AutoFilterMode = False
                Next ws
                
                wbk.Close SaveChanges:=False ' 关闭源工作簿，不保存修改
            Next selectedPath
        End If
    End With
    
    ' 清除剪贴板，取消复制状态
    Application.CutCopyMode = False
    MsgBox "数据合并完成！", vbInformation
End Sub

关键改进点 #

• 双重判断机制：
  1. 先检查lastRow > 1，确保工作表至少有表头之外的行；
  2. 用On Error Resume Next捕获SpecialCells的错误，再判断visibleDataRange是否有效，避免无可见数据时触发错误。
• 清理工作：关闭筛选、释放对象、清除剪贴板，避免残留状态影响后续操作。
• 容错性：即使某个工作表筛选后无结果，代码也会跳过该表，继续处理其他工作簿/工作表。

额外小贴士 #

• 把代码里的Field:=1、Criteria1:="你的筛选条件"、A2:Z替换成你实际使用的列号、筛选条件和数据范围；
• 如果你的表头不是第1行，记得调整对应的行号（比如把A2改成A3，lastRow >1改成lastRow >2）；
• 可以添加更多错误处理（比如处理文件打开失败的情况），让代码更健壮。

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