Excel 过滤数据，然后复制并粘贴不同的值

我在VBA方面有一些经验，但我不是专家，需要一些关于如何解决我的问题的建议。我有一个数据库，我需要应用2个过滤器。我有两个过滤器的以下代码：

Sub Filtering()
    'Filter Plant
    If IsEmpty(Worksheets("Material Planning").Range("D1")) = False Then
     If Worksheets("Material Planning").Range("D1") = "All" Then
      Worksheets("Inventory").Range("A:X").AutoFilter 'removes any filters
     Else
      Worksheets("Inventory").Range("A:X").AutoFilter Field:=1, Criteria1:=Worksheets("Material Planning").Range("D1")
     End If
    End If
    
    'Filter SLoc
    If IsEmpty(Worksheets("Material Planning").Range("D2")) = False Then
     If Worksheets("Material Planning").Range("D2") = "All" Then
      Worksheets("Inventory").Range("A:X").AutoFilter 'removes any filters
     Else
      Worksheets("Inventory").Range("A:X").AutoFilter Field:=2, Criteria1:=Worksheets("Material Planning").Range("D2")
     End If
    End If
End Sub

完成后，我需要提取不同的值，然后粘贴到不同的表中。我知道，通过操纵以下代码可以实现下半部分：

Sub ExtractDistinct()
Dim lastrow As Long

lastrow = Worksheets("Inventory").Cells(Rows.Count, "H").End(xlUp).Row

    Worksheets("Inventory").Range("H2:H" & lastrow).AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=Worksheets("Dictionary").Range("D4"), _
    Unique:=True

End Sub

使用上面的代码可以得到我要查找的不同值，但它不会对以前的“.AutoFilter”代码中的过滤范围进行过滤。它为我提供了与未过滤数据不同的值，并删除了我对数据使用的任何过滤器

我能够使用“.autofilter”来过滤我正在使用的工作表中的原始数据，但在excel中对数据进行物理过滤并不是我想要的（似乎也会对处理造成负担）。我希望能够过滤A列和B列中的数据，然后从C列中的过滤数据中提取所有不同的值，并将其复制到单独的工作表（而不是新的工作表）

谢谢你的帮助

筛选范围中的唯一值

选项显式
子过滤器
'声明一个布尔值，它将指示是否成功。
将Dim数据复制为布尔值
'定义工作簿。
将wb设置为工作簿：设置wb=ThisWorkbook包含此代码的工作簿
'定义标准值。
Dim Crit1作为变体
Crit1=工作表（“物料计划”）.范围（“D1”）.值
Dim Crit2作为变体
Crit2=工作表（“物料计划”）.范围（“D2”）.值
Application.ScreenUpdating=False
'定义源工作表
将ws设置为工作表：设置ws=wb.工作表（“库存”）
'删除自动筛选。
ws.AutoFilterMode=False
'定义资源范围（您可能需要另一种方式）。
将srg设置为量程：设置srg=ws.Range（“A1”）.CurrentRegion
'将筛选器应用于源范围。
如果不是空的（Crit1），那么
如果Crit1=“全部”，则
自动过滤器
其他的
srg.AutoFilter字段：=1，Criteria1:=crite1
如果结束
如果结束
如果不是空的（Crit2），那么
如果Crit2=“全部”，则
自动过滤器
其他的
srg.AutoFilter字段：=2，Criteria1:=crite2
如果结束
如果结束
'尝试定义复制范围。
出错时继续下一步
调暗crg As范围
设置crg=srg.Columns（3）。调整大小（srg.Rows.Count-1）。偏移量（1）_
.特殊单元格（xlCellTypeVisible）
错误转到0
'如果定义了复制范围（即创建了对其的引用）。。。
如果不是crg，那么什么都不是
'将唯一（不同）值写入唯一字典。
Dim dict As Object:Set dict=CreateObject（“Scripting.Dictionary”）
dict.CompareMode=vbTextCompare
Dim arg As范围
暗淡的cel As范围
变暗键作为变量
对于crg.区域中的每个参数
对于arg.单元格中的每个单元格
键=单元值
如果不是IsError（密钥），则
如果Len（Key）>0，则
dict（Key）=空
如果结束
如果结束
下一个细胞
下一个arg
长度为的Dim rCount:rCount=指令计数
如果rCount>0，则
'将唯一字典中的唯一值写入数据数组。
作为变量的Dim数据
我想我会坚持多久
重拨数据（1对rCount，1对1）
对于dict.Keys中的每个键
i=i+1
数据（i，1）=键
下一键
'将值从数据数组写入字典工作表。
使用wb.工作表（“字典”）.范围（“D4”）
.Resize（.Worksheet.Rows.Count-.Row+1）。ClearContent
.调整大小（i）.值=数据
dataCopied=True
以
如果结束
如果结束
Application.ScreenUpdating=True
如果数据被复制，那么
MsgBox“传输的唯一值”，vbInformation，“成功”
其他的
MsgBox“未传输任何内容”，vb感叹词，“失败？”
如果结束
端接头

此建议解决方案：

•使用而不是嵌套的

IF

s
•用于避免在

区域

和

单元格

（即范围内每个单元格的

）

•不验证过滤后的值，因为它们是应用标准的结果（即，目标是提取数据过滤后的唯一值）。

•使用如下行：
Dictionary.Item（Key）=任意值，其中
Key
=
Cell.value
，以确保每个
Cell.value
只向字典添加一条记录

Sub Data_Filter_N_Extract()
    Data_AutoFilter
    Data_Extract_Unique
    End Sub

Sub Data_AutoFilter()
Dim vCrt_A As Variant, vCrt_B As Variant

    Rem Get Criteria
    With ThisWorkbook.Worksheets("Material Planning")
        vCrt_A = .Range("D1").Value
        vCrt_B = .Range("D2").Value
    End With

    With ThisWorkbook.Worksheets("Inventory").Range("A:X")
        
        Rem Filter Plant
        Select Case vCrt_A
        Case vbNullString                                               'NO ACTION!. Any filter already applied to column [A] will stay.
        Case "All":         .AutoFilter                                 'Removes all filters from the entire range [A:X]
        Case Else:          .AutoFilter Field:=1, Criteria1:=vCrt_A     'Apply filter as per [D1] value
        End Select
                
        Rem Filter SLoc
        Select Case vCrt_B
        Case vbNullString:                                              Rem NO ACTION!. Any filter already applied to the column [B] will stay.
        Case "All":         .AutoFilter                                 'Removes all filters from the entire range [A:X]
        Case Else:          .AutoFilter Field:=2, Criteria1:=vCrt_B     'Apply filter as per [D2] value
        End Select
    
    End With

    End Sub


Sub Data_Extract_Unique()
Dim Rng As Range
Dim Dtn As Object, Cll As Range
Dim lRow As Long, sMsg As String
    
    Rem Set output cell & clear prior data
    Set Rng = ThisWorkbook.Sheets("Dictionary").Range("D4")
    With Rng
        .Resize(-3 + .Worksheet.Rows.Count).ClearContents
        .Value = "In progress…"     'Indicate that a process has started
    End With
    
    Rem Extract & post unique values
    With ThisWorkbook.Sheets("Inventory").Columns("C:C")
        
        Rem Get last row of columns [C] in Data
        lRow = .Cells(Rows.Count).End(xlUp).Row
        
        Rem Validate Last Row
        Select Case lRow
        
        Case 1      'Last row = 1 - Filter returned 0 records
            sMsg = "Filtered data shows 0 records to extract!"
        
        Case 2      'Last row = 2 - Filter returned 1 record
            sMsg = "1 Unique value extracted from filtered data"
            Rng.Value = .Cells(2).Value:

        Case Else   'Last row = any other row - Filter returned several recorda
        
            Rem Use a dictionary to filter out duplicated values
            Set Dtn = CreateObject("Scripting.Dictionary")
            With Range(.Cells(2), .Cells(lRow)).SpecialCells(xlCellTypeVisible)
                For Each Cll In .Cells
                    Dtn.Item(Cll.Value) = Cll.Value
            
            Next: End With
            
            Rem Post Dictionary to the Output Range (Keys or Items - pick one)
            With Dtn
                sMsg = .Count & " Unique values extracted from filtered data"
                Rem Any of these two lines would work as the Keys and Items are the same (pick one)
                Rng.Resize(.Count).Value = Application.Transpose(.Keys)
                'Rng.Resize(.Count).Value = Application.Transpose(.Items)
            End With
    
    End Select: End With

    MsgBox sMsg, vbInformation, "Data Extract Unique"

End Sub

我们可以看到过滤数据库的
AutoFilter
代码吗？我更新了我的帖子，以获得我目前正在使用的代码。如果您还需要什么，请告诉我。感谢您告诉我，我的解决方案中的
区域
是“冗余”（不正确），即
单元格
将“覆盖”所有单元格，即使范围不连续。这对我来说是一个宝贵的教训。请注意，
行
和
列
将只引用非连续范围的第一个
区域
，这导致我首先使用
区域
。@VBASIC208我不会认为它不正确，因为它返回所有正确的结果。注意，在某些情况下，使用区域（即返回非连续范围内的所有项目）更有效。哇，这工作完美无瑕！它的处理时间也非常快，令人惊讶！