Excel VBA筛选行粘贴至新工作表失败求助

你的代码无法完成粘贴操作，核心问题集中在引用不明确、逻辑错误、保存逻辑矛盾以及错误掩盖这几点：

• 未明确工作表引用：Range("B2").End(xlDown).End(xlToRight) 未指定所属工作表，默认指向当前活动表，大概率不是目标的"Base"工作表，导致复制范围错误。
• 筛选值定位错误：用累加的total来定位K列单元格，和选中的rng行号不对应，导致筛选条件错误，自然没有数据可复制。
• 保存逻辑矛盾：粘贴内容后关闭工作簿时设置SaveChanges:=False，直接丢弃了粘贴的内容。
• 错误掩盖：On Error Resume Next 隐藏了所有错误，比如文件路径无效、工作表不存在等问题，无法定位真正的故障点。

修正后的代码 #

Sub Macro1()
    Dim rng As Range
    Dim WorkRng As Range
    Dim sourceWs As Worksheet
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim contratante As String
    Dim savePath As String
    
    ' 初始化源工作表对象，避免依赖ActiveSheet
    Set sourceWs = ThisWorkbook.Worksheets("Base")
    savePath = "C:\Users\WMRamthun\OneDrive - META CENTRAL DE SERVICOS LTDA\Relatorios Bio\OA\Relatorio NOVO\"
    
    ' 获取用户选择的范围
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Selecione o intervalo", "Contar Preenchidas", WorkRng.Address, Type:=8)
    
    ' 遍历选中的每个单元格
    For Each rng In WorkRng
        If Not IsEmpty(rng.Value) Then
            ' 从当前rng所在行的K列获取筛选值
            contratante = sourceWs.Range("K" & rng.Row).Value
            If contratante = "" Then GoTo NextRng ' 跳过空的筛选值
            
            ' 创建新工作簿并设置工作表对象
            Set newWb = Workbooks.Add
            Set newWs = newWb.Worksheets(1)
            
            ' 应用筛选
            sourceWs.Range("B2").AutoFilter Field:=1, Criteria1:=contratante, VisibleDropDown:=False
            
            ' 复制筛选后的可见数据（包含表头）
            On Error Resume Next ' 临时处理无数据的情况
            sourceWs.Range("B2:H2").Resize(sourceWs.Cells(sourceWs.Rows.Count, "B").End(xlUp).Row - 1).SpecialCells(xlCellTypeVisible).Copy
            On Error GoTo 0 ' 恢复错误处理
            
            ' 粘贴值到新工作簿
            If Err.Number = 0 Then
                newWs.Range("A2").PasteSpecial Paste:=xlPasteValues
                ' 保存并关闭新工作簿
                newWb.SaveAs Filename:=savePath & contratante & ".xlsx"
            Else
                ' 无匹配数据时，删除空工作簿
                newWb.Close SaveChanges:=False
            End If
            
            ' 清除筛选
            sourceWs.AutoFilterMode = False
        End If
NextRng:
    Next rng
    
    MsgBox "Processamento concluído! Total de células processadas: " & WorkRng.Cells.Count
End Sub

关键修改说明 #

• 明确对象引用：用sourceWs、newWb、newWs等变量直接指向目标对象，彻底避免ActiveSheet/ActiveWorkbook带来的不确定性。
• 修正筛选值逻辑：通过rng.Row获取当前遍历单元格的行号，准确对应K列的筛选值。
• 处理无数据场景：添加错误捕获，当筛选后没有可见数据时，直接关闭空工作簿，避免生成无效文件。
• 修复保存逻辑：粘贴成功后再保存工作簿，确保更改被留存。
• 移除全局变量：把Contratante改为过程内局部变量，避免全局变量带来的意外干扰。

内容的提问来源于stack exchange，提问作者Willian Mateus Ramthun