Excel VBA 根据名称过滤多个工作表并另存为单独的文件

Question

我有一份包含 4 个工作表的报告：1 个首页和 3 个必须按名称过滤的工作表。过滤后，工作表必须保存为单独的文件。

我现在正在使用以下代码（见下文），但我有一些问题：

1. 如何删除不符合条件的数据？因此，当在 Name1 上过滤数据时，应删除所有其他名称。
2. 如何将首页 (sheet1) 与 3 个过滤后的工作表一起复制到 1 个文件中？它现在只复制 3 个过滤的工作表。无需过滤首页。
3. 如何将数据粘贴为值（现在已粘贴为公式）？

Option Explicit

Sub AutoFilters()
Dim sheetsToFilter As Variant, sheetName As Variant
Dim sheetsColumnToFilterOn As Variant
Dim criteria As Variant, criterium As Variant
Dim iSht As Long
Dim pre As String

sheetsToFilter = Array("Sheet2", "Sheet3", "Sheet4")
sheetsColumnToFilterOn = Array(2, 3, 4)
criteria = Array("Name1", "Name2", "Name3")

pre = Format(Now, "dd-mm-yyyy")

Application.ScreenUpdating = False

For Each criterium In criteria
    For iSht = LBound(sheetsToFilter) To UBound(sheetsToFilter)
        Call Autofilter(ThisWorkbook.Worksheets(sheetsToFilter(iSht)).Range("A1"), CLng(sheetsColumnToFilterOn(iSht)), CStr(criterium))
    Next iSht

    Call CopySheet(sheetsToFilter, ThisWorkbook.Path & "\" & criterium & " " & pre & ".xlsx")
Next criterium

Application.ScreenUpdating = True

End Sub


Sub Autofilter(rng As Range, col As Long, criteria As String)

With rng
    .Autofilter
    .Autofilter field:=col, Criteria1:=criteria & "*", VisibleDropDown:=True
End With

End Sub


Sub CopySheet(sheetsToFilter As Variant, shtName As String)

ThisWorkbook.Worksheets(sheetsToFilter).Copy
ActiveWorkbook.SaveAs Filename:=shtName, FileFormat:=xlWorkbookDefault
ActiveWorkbook.Close False

End Sub

提前致谢！

Answer 1

备份工作表

1. "<>" & Criteria(n) & "*"
2. swb.Worksheets(Array(wsNames(0), wsNames(n))).Copy
3. rg.Value = rg.Value

Option Explicit

Sub CreateBackups()
    
    Const wsNamesList As String = "Sheet1,Sheet2,Sheet3,Sheet4"
    Const CriteriaList As String = ",Name1,Name2,Name3"
    
    Dim fFields As Variant: fFields = VBA.Array(, 2, 3, 4)
    Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    
    Dim dStamp As String: dStamp = Format(Date, "dd-mm-yyyy")
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim dFolderPath As String: dFolderPath = swb.Path
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook
    Dim ws As Worksheet
    Dim rg As Range
    Dim drg As Range ' Delete Range
    Dim dFilePath As String
    Dim n As Long
    
    For n = 1 To UBound(wsNames) ' 0 is front sheet
        swb.Worksheets(Array(wsNames(0), wsNames(n))).Copy
        Set dwb = ActiveWorkbook
        Set ws = dwb.Worksheets(wsNames(n))
        If ws.AutoFilterMode Then ws.AutoFilterMode = False
        Set rg = ws.Range("A1").CurrentRegion
        rg.Value = rg.Value
        rg.AutoFilter fFields(n), "<>" & Criteria(n) & "*"
        Set drg = Nothing
        On Error Resume Next
        rg.Resize(rg.Rows.Count - 1, 1).Offset(1, fFields(n) - 1) _
            .SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0
        ws.AutoFilterMode = False
        dFilePath = dFolderPath & "\" & Criteria(n) & " " & dStamp & ".xlsx"
        Application.DisplayAlerts = False ' overwrite without alerts
        dwb.SaveAs dFilePath, xlWorkbookDefault
        Application.DisplayAlerts = True
        dwb.Close
    Next n

    Application.ScreenUpdating = False

    MsgBox "Today's worksheet backups created.", vbInformation, "Backup"

End Sub