VBA根据每个工作表中的A列过滤器复制多个工作表并创建新工作簿

Question

我在工作簿中有 3 个合并工作表，我需要根据每张工作表 A 列中的唯一值将其分成 3 个工作表中的新工作表：

在“A”工作簿中，所有 3 张工作表，每张工作表都应该只有其信息，并且需要循环查找所有名称。

下面的代码仅将数据从工作簿移动到工作簿，但没有太大帮助。

Answer 1

按名称备份工作表

• 这是一个稍微简化的示例，假设每个表都以 A1 开头，工作表未过滤，名称位于第 1 列 (“A”)，第一个工作表 (Sales) 包含所有唯一值（名称），...

• 对于每个唯一值（名称），它只会将列表中的工作表复制到新工作簿中。然后它遍历新工作簿中的所有工作表并删除不包含值的行，使标题保持不变。最后，它会保存新的工作簿。

Option Explicit

Sub BackupByName()
    
    Const wsNamesList As String = "Sales,Marketing,Operations"
    Const First As String = "A1" ' You cannot change this...1
    
    Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim dFolderPath As String: dFolderPath = swb.Path & "\"
    
    ' Assuming that "Sales" contains all names.
    Dim ws As Worksheet: Set ws = swb.Worksheets(wsNames(0))
    
    Dim rg As Range: Set rg = RefColumn(ws.Range(First).Offset(1))
    If rg Is Nothing Then Exit Sub ' range reference cannot be created
    
    Dim Data As Variant: Data = GetRange(rg)
    
    Dim uData As Variant: uData = ArrUniqueData(Data)
    If IsEmpty(uData) Then Exit Sub ' no unique values
    
    Dim uUpper As Long: uUpper = UBound(uData)
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim drg As Range
    Dim n As Long
    Dim nName As String
    Dim dName As String
    
    For n = 0 To uUpper
        swb.Worksheets(wsNames).Copy
        Set dwb = ActiveWorkbook
        nName = uData(n)
        For Each dws In dwb.Worksheets
            '1... because of these simplifications.
            Set rg = dws.Range(First).CurrentRegion.Columns(1)
            rg.Columns.AutoFilter 1, "<>" & Name
            Set drg = Nothing
            On Error Resume Next
            Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1) _
                .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not drg Is Nothing Then
                drg.EntireRow.Delete
            End If
            dws.AutoFilterMode = False
        Next dws
        dName = dFolderPath & nName & ".xlsx"
        Application.DisplayAlerts = False
        dwb.SaveAs Filename:=dName, FileFormat:=xlOpenXMLWorkbook ' 51
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next n

    Application.ScreenUpdating = True

End Sub
   
Function RefColumn( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    With FirstCellRange.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With
End Function
   
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    Dim rData As Variant
    If rg.Rows.Count + rg.Columns.Count = 2 Then
        ReDim rData(1 To 1, 1 To 1): rData(1, 1) = rg.Value
    Else
        rData = rg.Value
    End If

    GetRange = rData
End Function

Function ArrUniqueData( _
    Data As Variant, _
    Optional ByVal CompareMethod As VbCompareMethod = vbTextCompare) _
As Variant
    
    If IsEmpty(Data) Then Exit Function
    
    Dim cLower As Long: cLower = LBound(Data, 2)
    Dim cUpper As Long: cUpper = UBound(Data, 2)
    
    Dim Key As Variant
    Dim r As Long
    Dim c As Long
    With CreateObject("Scripting.Dictionary")
        .CompareMode = CompareMethod
        For r = LBound(Data, 1) To UBound(Data, 1)
            For c = cLower To cUpper
                Key = Data(r, c)
                If Not IsError(Key) Then
                    If Len(Key) > 0 Then
                        .Item(Key) = Empty
                    End If
                End If
            Next c
        Next r
        If .Count = 0 Then Exit Function
        ArrUniqueData = .Keys
    End With

End Function