VBA宏批量保存多工作表异常：仅最后工作表未筛选数据生效求助

问题根源 #

1. 文件名重复覆盖：原循环中每次使用相同文件名保存文件，后续文件会覆盖之前的，最终仅保留最后一个工作表的导出结果。
2. 未筛选数据导出：直接复制整个工作表会包含所有行（包括筛选隐藏的部分），没有只导出筛选后的可见数据。

修改后的代码（每个工作表单独生成文件） #

Sub ExportFilteredXLSM()
    Dim myWorksheets() As String
    Dim newWB As Workbook
    Dim CurrWB As Workbook
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim userpath As String
    Dim sToday As String
    Dim MyPath As String
    Dim MyFileName As String
    
    Set CurrWB = ThisWorkbook
    userpath = Environ("UserProfile")
    
    ' 获取日期
    Set ws = CurrWB.Sheets("Monthly_Budget")
    sToday = ws.Range("A7").Value
    
    ' 要导出的工作表列表
    myWorksheets = Split("Summary, Monthly_Budget, History_1", ",")
    
    ' 选择保存路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存位置并点击确定!"
        .AllowMultiSelect = False
        .InitialFileName = userpath & "\Desktop\" ' 修正路径格式，去掉多余空格
        If .Show <> -1 Then Exit Sub ' 用户取消则退出
        MyPath = .SelectedItems(1) & "\"
    End With
    
    ' 关闭屏幕刷新，提升效率
    Application.ScreenUpdating = False
    
    ' 遍历每个工作表
    Dim i As Integer
    For i = LBound(myWorksheets) To UBound(myWorksheets)
        Set ws = CurrWB.Sheets(Trim(myWorksheets(i)))
        
        ' 检查工作表是否有筛选
        If ws.AutoFilterMode Then
            ' 创建新工作簿
            Set newWB = Workbooks.Add
            Set targetWs = newWB.Sheets(1)
            
            ' 复制筛选后的可见数据（包括表头）
            ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
            targetWs.Range("A1").PasteSpecial Paste:=xlPasteAll ' 复制格式和数据
            targetWs.Name = ws.Name ' 重命名目标工作表
            
            ' 生成唯一文件名，避免覆盖
            MyFileName = "KIG_BUDGET_2024_" & sToday & "_" & ws.Name & ".xlsm"
            
            ' 保存并关闭新工作簿
            newWB.SaveAs Filename:=MyPath & MyFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            newWB.Close saveChanges:=False
        Else
            ' 如果没有筛选，提示用户
            MsgBox ws.Name & " 未启用筛选，跳过导出。"
        End If
    Next i
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "导出完成!"
End Sub

关键改动说明 #

• 唯一文件名：在文件名后添加工作表名称，避免不同工作表的导出文件互相覆盖。
• 筛选数据导出：使用SpecialCells(xlCellTypeVisible)仅复制筛选后的可见区域，确保导出的是筛选后的数据。
• 路径格式修正：原代码中InitialFileName的路径有多余空格，修正为正确的格式。
• 屏幕刷新控制：添加Application.ScreenUpdating = False提升运行效率，避免界面频繁闪烁。
• 筛选检查：增加判断，若工作表未启用筛选则提示并跳过，避免无效导出。

可选：导出所有筛选后工作表到同一个文件 #

如果需要将所有筛选后的工作表保存到同一个新工作簿，可使用以下代码：

Sub ExportAllFilteredToOneFile()
    Dim myWorksheets() As String
    Dim newWB As Workbook
    Dim CurrWB As Workbook
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim userpath As String
    Dim sToday As String
    Dim MyPath As String
    Dim MyFileName As String
    
    Set CurrWB = ThisWorkbook
    userpath = Environ("UserProfile")
    
    ' 获取日期
    Set ws = CurrWB.Sheets("Monthly_Budget")
    sToday = ws.Range("A7").Value
    
    ' 要导出的工作表列表
    myWorksheets = Split("Summary, Monthly_Budget, History_1", ",")
    
    ' 选择保存路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存位置并点击确定!"
        .AllowMultiSelect = False
        .InitialFileName = userpath & "\Desktop\"
        If .Show <> -1 Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    
    Application.ScreenUpdating = False
    
    ' 创建一个新工作簿用于存放所有筛选后的数据
    Set newWB = Workbooks.Add
    
    For i = LBound(myWorksheets) To UBound(myWorksheets)
        Set ws = CurrWB.Sheets(Trim(myWorksheets(i)))
        
        If ws.AutoFilterMode Then
            ' 添加新工作表到目标工作簿
            Set targetWs = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count))
            targetWs.Name = ws.Name
            
            ' 复制可见数据
            ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
            targetWs.Range("A1").PasteSpecial Paste:=xlPasteAll
        Else
            MsgBox ws.Name & " 未启用筛选，跳过导出。"
        End If
    Next i
    
    ' 删除默认的空白工作表（如果存在）
    If newWB.Sheets.Count > UBound(myWorksheets) - LBound(myWorksheets) + 1 Then
        Application.DisplayAlerts = False
        newWB.Sheets("Sheet1").Delete
        Application.DisplayAlerts = True
    End If
    
    ' 保存文件
    MyFileName = "KIG_BUDGET_2024_" & sToday & ".xlsm"
    newWB.SaveAs Filename:=MyPath & MyFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    newWB.Close saveChanges:=False
    
    Application.ScreenUpdating = True
    MsgBox "导出完成!"
End Sub

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