過濾 excel 列並將粘貼復制到另一個新工作表，工作表名稱應為過濾器值

Question

我正在對 column1 應用過濾器並將數據粘貼到新工作表我正在嘗試添加具有過濾器名稱的新工作表，例如：第 1 列有 a、b、c，新工作表應該是 a、b、c。 附上我試過的代碼。你能幫我解決這個問題嗎？ 提前致謝。

Sub filter()`enter code here`
    Application.ScreenUpdating = False
    Dim x As Range
    Dim rng As Range
    Dim last As Long
    Dim sht As String

    'specify sheet name in which the data is stored
    sht = "DATA Sheet"

    'change filter column in the following code
    last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
    Set rng = Sheets(sht).Range("A1:F" & last)

    Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

    For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
    With rng
    .AutoFilter
    .AutoFilter field:=6, Criteria1:=x.Value
    .SpecialCells(xlCellTypeVisible).Copy
    i = x
    For i = 2 To last
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = Range("a" & x).Value
    'Sheets.Add.Name = Range("a3").Value
    Next i
    ActiveSheet.Paste

    End With
    Next x

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False

    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With

End Sub

Answer 1

如果 A 列是名稱所在的位置，則將過濾器放在 A 列上。

Option Explicit

Sub FilterToSheet()

    Dim rng As Range, rngCopy As Range, x, arNames
    Dim last As Long, sht As String, n As Long

    'specify sheet name in which the data is stored
    sht = "DATA Sheet"

    ' filter on column A
    With Sheets(sht)
        .AutoFilterMode = False
        
        last = .Cells(Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("A1:F" & last)
        .Columns("AA:AA").Clear
        .Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, _
           CopyToRange:=.Range("AA1"), Unique:=True
        last = .Cells(Rows.Count, "AA").End(xlUp).Row
        
        ' list of filter names
        arNames = .Range("AA2:AA" & last).Value
        .Columns("AA:AA").Clear
    End With
    
    Application.ScreenUpdating = False
    
    ' aply filter for each name
    For Each x In arNames
        
        With rng
            .AutoFilter
            .AutoFilter field:=1, Criteria1:=x
            Set rngCopy = .SpecialCells(xlCellTypeVisible)
        End With
        
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = x
        rngCopy.Copy
        ActiveSheet.Paste
        ActiveSheet.Range("A1").Select
        n = n + 1
        
    Next x

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    Sheets(sht).Activate

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    MsgBox n & " sheets created", vbInformation
End Sub