進階篩選以復制到新的工作表

Question

我正在嘗試自動過濾列，並將所有唯一值復制/粘貼到每個新表中。 這是我一直在使用的代碼，但是在運行代碼時遇到此錯誤：

運行時錯誤'1004'：提取范圍的字段名稱缺失或無效。

Sub Filter()

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 = "Filter This"

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

Sheets(sht).Range("C1:C" & 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:=3, Criteria1:=x.Value
    .SpecialCells(xlCellTypeVisible).Copy

Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x

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

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


End Sub

Answer 1

您可以使用集合來過濾出唯一項，而不是使用高級過濾器。

Sub UsingCollection()
    Dim cUnique As Collection, ws As Worksheet, fRng As Range
    Dim Rng As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant

    Set sh = ThisWorkbook.Sheets("Filter This")
    Set Rng = sh.Range("C2:C" & sh.Cells(sh.Rows.Count, "C").End(xlUp).Row)
    Set cUnique = New Collection

    On Error Resume Next
    For Each Cell In Rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0

    For Each vNum In cUnique
        With sh
            Set fRng = .Range("C1:H" & .Cells(.Rows.Count, "C").End(xlUp).Row)
        End With
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        With ws
            .Name = vNum
            With fRng
                .AutoFilter Field:=3, Criteria1:=vNum
                fRng.Copy ws.Range("A1")
            End With
            .AutoFilterMode = False
        End With
    Next vNum

End Sub