过滤并将过滤后的唯一数据复制到另一张纸上；工作表名称将是唯一值

Question

'我有一本包含数据表的工作簿。我需要过滤唯一的编号，然后将过滤后的数据复制到另一个工作表中，工作表名称将是唯一的编号。

'我尝试获取所有数字并删除重复的数字，其余的应该是要复制的过滤后的数字。

'错误是我可以将数据复制到不同的工作表中，但不能根据其唯一编号进行过滤

Sub filter()

Dim i As Integer
Dim ST As String
On Error Resume Next
i = 1
Application.ScreenUpdating = False

Do
ST = Sheets("duplicateshipto").Range("A" & i).Value
If ST <> "" Then
Sheets.Add.Name = ST
With Sheets("Template")
.Select
.Range("C1:BQ4").Select

Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("A1").Select
Sheets(ST).Paste

.Select
ActiveSheet.Range("$A$4:$BU$88").AutoFilter Field:=26, Criteria1:=gsd


.Range("Z4", .Range("BS" & .Rows.Count).End(xlUp)).Select

Range("Z4").Select
Selection.End(xlDown).Select
.Range(Selection, Selection.End(xlDown)).Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("x5").Select
Sheets(ST).Paste
.Select
Range("BQ4").Select
Selection.End(xlDown).Select
.Range(Selection, Selection.End(xlDown)).Select
.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("BO6").Select
Sheets(ST).Paste
.Select
Range("Y4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
'Range(Selection, Selection.End(xlToLeft)).Select
Selection.Copy
Sheets(ST).Select
Sheets(ST).Range("a5").Select
Sheets(ST).Paste

End With
i = i + 1
End If
Loop Until ST = ""

Application.ScreenUpdating = True


End Sub

Answer 1

您实质上是在尝试做名为Advanced Filter的事情。但是，您的代码需要对所有选择选项进行一些改进（如注释状态所示）。这是一个示例宏，其中包含一些您要执行的操作所需的组件，例如：

• 它动态地捕获到所有F6左侧和下方的已填充单元格的范围。
• 使用绿色范围作为过滤范围（如果不只是将F3：H3留空）
• 插入从单元格A1开始的值，该值具有基于数据列数的动态列数。
• 使用Unique:=True排除重复项（示例中仅重复一项）

在宏之前

宏之后

上图中使用的代码。

Sub exampleRefresh()
Dim cRng As Range, WS As Worksheet
Set WS = ActiveSheet

With WS
    Set cRng = Sheet1.Range("F6")
    Set cRng = Range(cRng, cRng.End(xlToRight))
    Set cRng = Range(cRng, cRng.End(xlDown))

    Dim fRng As Range
    Set fRng = WS.Range("F2:H3")

    Dim PRNG As Range
    Set PRNG = WS.Range("A1")
    Set PRNG = Range(PRNG, PRNG.Offset(, cRng.Columns.Count - 1))

End With


  cRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=fRng, CopyToRange:=PRNG, Unique:=True


End Sub

此外，作为预告片，微软将部署新的Spill Feature soon。使用此功能，如果要列出一列的不同值，则可以在任何单元格中使用诸如=Unique(A:A)之类的公式，它将创建一个不同的列表。不需要VBA或点击过多！