我在 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 列中的数据，然后从 Filtered Data From C 列中提取所有不同的值，并将其复制到单独的工作表（不是新工作表）。
感谢您的帮助！
答案 0 :(得分：1)
这个提议的解决方案：
• 使用 Select Case statement 而不是嵌套的 IFs
• 使用For Each...Next statement 来避免Areas 和Cells（即For Each Cell in Range.Cells）上的双重循环
• 不验证过滤值，因为它们是应用标准的结果（即目标是提取数据过滤结果的唯一值）。
• 使用如下一行：Dictionary.Item(Key) = Any value where 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
答案 1 :(得分：0)
Option Explicit
Sub filterUnique()
' Declare a boolean which will indicate if successful.
Dim dataCopied As Boolean
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Define Criteria Values.
Dim Crit1 As Variant
Crit1 = wb.Worksheets("Material Planning").Range("D1").Value
Dim Crit2 As Variant
Crit2 = wb.Worksheets("Material Planning").Range("D2").Value
Application.ScreenUpdating = False
' Define Source Worksheet
Dim ws As Worksheet: Set ws = wb.Worksheets("Inventory")
' Remove AutoFilter.
ws.AutoFilterMode = False
' Define Souce Range (you may need to do it another way).
Dim srg As Range: Set srg = ws.Range("A1").CurrentRegion
' Apply filters to Source Range.
If Not IsEmpty(Crit1) Then
If Crit1 = "All" Then
srg.AutoFilter
Else
srg.AutoFilter Field:=1, Criteria1:=Crit1
End If
End If
If Not IsEmpty(Crit2) Then
If Crit2 = "All" Then
srg.AutoFilter
Else
srg.AutoFilter Field:=2, Criteria1:=Crit2
End If
End If
' Attempt to define Copy Range.
On Error Resume Next
Dim crg As Range
Set crg = srg.Columns(3).Resize(srg.Rows.Count - 1).Offset(1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' If Copy Range was defined (i.e. a reference to it was created)...
If Not crg Is Nothing Then
' Write unique (distinct) values to Unique Dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim arg As Range
Dim cel As Range
Dim Key As Variant
For Each arg In crg.Areas
For Each cel In arg.Cells
Key = cel.Value
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Empty
End If
End If
Next cel
Next arg
Dim rCount As Long: rCount = dict.Count
If rCount > 0 Then
' Write unique values from Unique Dictionary to Data Array.
Dim Data As Variant
Dim i As Long
ReDim Data(1 To rCount, 1 To 1)
For Each Key In dict.Keys
i = i + 1
Data(i, 1) = Key
Next Key
' Write values from Data Array to Dictionary Worksheet.
With wb.Worksheets("Dictionary").Range("D4")
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(i).Value = Data
dataCopied = True
End With
End If
End If
Application.ScreenUpdating = True
If dataCopied Then
MsgBox "Unique values transferred.", vbInformation, "Success"
Else
MsgBox "Nothing transferred.", vbExclamation, "Fail?"
End If
End Sub