VBA复制筛选数据至新工作表时Runtime Error 1004报错求助

我来帮你搞定这个报错——核心问题出在你复制数据的方式上，我们先搞清楚为什么会报错，再给你两种可靠的修正方案：

为什么你的代码会触发1004错误？ #

你原来写的Cells.Select + Selection.SpecialCells(xlCellTypeVisible).Copy有两个致命问题：

1. 它会选中包括表头在内的所有可见单元格，而你实际只想复制表头以外的数据行。
2. 当符合条件的行是不连续的（比如中间隔了不符合条件的行），Excel无法将多个不连续的单元格区域粘贴到非A1起始的位置，这就是报错提示的原因。

而你参考的正常宏里用的.Parent.AutoFilter.Range.Offset(1).Copy是非常可靠的写法：它会自动定位到筛选后的整个数据区域，Offset(1)直接跳过表头，只取需要的数据行，而且Excel会处理好区域连续性的问题。

方案1：沿用原宏的可靠结构（推荐） #

这个方案保留你参考的正常宏的核心逻辑，只移除你不需要的自动筛选和列隐藏，同时适配你的需求：

Sub BBWin()
'
' BB Win Macro
' 此宏将筛选BB Win 1 - 8
'
With ActiveSheet.Range("A1").CurrentRegion
    With .Resize(, .Columns.Count + 1) ' 扩展出辅助列用于标记符合条件的行
        With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
            ' 你的条件判断公式，保持不变
            .FormulaR1C1 = "=if(or(rc7={""K.BB_Win_1_2019"",""K.BB_Win_2_2019"",""K.BB_Win_3_2019"",""K.BB_Win_4_2019"",""K.BB_Win_5_2019"",""K.BB_Win_6_2019"",""K.BB_Win_7_2019"",""K.BB_Win_8_2019""}),""X"","""")"
            .Value = .Value ' 将公式转换为固定值
        End With
        .HorizontalAlignment = xlCenter
        
        ' 新增：用AutoFilter筛选出辅助列为"X"的符合条件的行
        .AutoFilter Field:=.Columns.Count, Criteria1:="X"
    End With
    
    ' 复制筛选后除表头外的所有可见数据（和正常宏的可靠写法一致）
    .Parent.AutoFilter.Range.Offset(1).Copy
    
    ' 粘贴到目标工作表的第一个空白行
    With Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports")
        .Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    End With
    
    ' 恢复原工作表状态：移除自动筛选
    .AutoFilterMode = False
    ' 可选：删除辅助列，如果你不需要保留它的话
    .Resize(, .Columns.Count + 1).Columns(.Columns.Count + 1).Delete
End With
Application.CutCopyMode = False
End Sub

关键修改点： #

• 新增了AutoFilter筛选辅助列的步骤，确保只有符合条件的行被选中。
• 用原宏的.Parent.AutoFilter.Range.Offset(1).Copy替代了错误的Cells.Select逻辑，避免不连续区域粘贴的问题。
• 最后移除自动筛选并删除辅助列，恢复原表的初始状态。

方案2：不用AutoFilter的替代写法 #

如果你不想改动原表的筛选状态，也可以用这种直接定位符合条件行的方式：

Sub BBWin_Alternative()
'
' BB Win Macro（无AutoFilter版本）
' 此宏将筛选BB Win 1 - 8
'
Dim sourceRange As Range
Dim targetRow As Long

With ActiveSheet.Range("A1").CurrentRegion
    With .Resize(, .Columns.Count + 1) ' 扩展辅助列
        With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
            .FormulaR1C1 = "=if(or(rc7={""K.BB_Win_1_2019"",""K.BB_Win_2_2019"",""K.BB_Win_3_2019"",""K.BB_Win_4_2019"",""K.BB_Win_5_2019"",""K.BB_Win_6_2019"",""K.BB_Win_7_2019"",""K.BB_Win_8_2019""}),""X"","""")"
            .Value = .Value
        End With
        .HorizontalAlignment = xlCenter
        
        ' 定位辅助列中为"X"的单元格，对应到数据行区域
        On Error Resume Next ' 防止没有符合条件的行时出错
        Set sourceRange = .Columns(.Columns.Count).SpecialCells(xlCellTypeConstants, xlTextValues).Offset(0, -.Columns.Count + 1).Resize(, .Columns.Count - 1)
        On Error GoTo 0
    End With
    
    ' 如果找到符合条件的行，就复制到目标表
    If Not sourceRange Is Nothing Then
        targetRow = Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports").Range("A" & Rows.Count).End(xlUp).Row + 1
        sourceRange.Copy
        Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports").Range("A" & targetRow).PasteSpecial xlPasteValues
    End If
    
    ' 删除辅助列
    .Resize(, .Columns.Count + 1).Columns(.Columns.Count + 1).Delete
End With
Application.CutCopyMode = False
End Sub

这个方案的特点： #

• 不需要使用AutoFilter，不会改变原表的筛选状态。
• 用SpecialCells直接定位符合条件的行，代码更简洁，但需要处理“没有符合条件的行”的异常情况。

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