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

Question

I have 3 consolidated sheet in a workbook which I need to segregate into 3 sheets in new workbook based on unique values in column A of each sheet:

In the "A" workbook, all 3 sheets each sheet should have only its information and needs to loop for all names.

Below the code that only moves data from workbook to workbook, but is not much helpful.

Answer 1

Backup Worksheets by Name

• This is a somewhat simplified example that assumes that each table starts in A1 , that the worksheets are not filtered, that the names are in column 1 ("A"), that the first worksheet ( Sales ) contains all the unique values (names),...

• For each unique value (name) it copies only the worksheets from the list to a new workbook. Then it loops through all the worksheets in the new workbook and deletes the rows that do not contain the value leaving the headers intact. Finally, it saves the new workbook.

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