[英]Advance Filter to copy to new sheets
我正在尝试自动过滤列,并将所有唯一值复制/粘贴到每个新表中。 这是我一直在使用的代码,但是在运行代码时遇到此错误:
运行时错误'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
您可以使用集合来过滤出唯一项,而不是使用高级过滤器。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.