我有一个炉灶和一张桌子。
我想检查某个范围内的重复项，然后我想从表中过滤这些项...下面是我所做的，但没有效果。
我已经编写了一个代码，用于在选择中制作重复项目的列表/数组/范围。
然后我将这个列表/数组/范围重复项传递给 autoFilter 的 Criteria1。但它不起作用。它什么都没过滤。
' making of an array/ range of duplicates from selection
Dim Ary As Variant, cell As Range, i As Integer
i = 0
ReDim Ary(0)
For Each cell In Selection
If WorksheetFunction.CountIf(Selection, cell) >= 2 Then
Ary(i) = cell.Value
i = i + 1
ReDim Preserve Ary(i)
End If
Next
'If I put msgbox Ary(0) here then it shows me a value but overall the code is not working for autofilter && is it possible to use above code as separate function
'apply filter with duplicate values
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=3, Criteria1:= _
Ary, Operator:=xlFilterValues
End Sub
答案1
微软没有告诉您的事情第 94 部分...
方法中使用的过滤条件值Autofilter必须指定为文本字符串，即使您要过滤的列包含数字。
将用于构建Ary数组的赋值语句更改为
Ary(i) = CStr(cell.Value)
确保数组包含文本字符串。
更好的是，另外声明Ary为字符串数组
Dim Ary() As String
Ary而不是作为一种变体，因此从一开始就明确了意图。
有一个提示自动筛选方法的文档必须将数字作为文本字符串传递给条件参数 - 请参阅文档中列出的第三个示例 - 但没有强调这一要求。
答案2
返回数组中唯一重复项
- 将唯一重复值放入数组的最有效（最快）方法通常是使用字典：首先将所有值及其计数写入字典，然后循环遍历字典中的键并删除每个项值为 1 的键。
- 要“获取”一个数组或任何其他结果，您必须使用从您的程序中调用的函数，
例如Dim Ary As Variant: Ary = ArrMultiRangeDuplicates(Range("A1:A10,D5:d13")。 - 要“将数组转换为文本”，您可以使用我在子示例中使用的这个简单技巧：
Ary = Split(Join(Ary, vbLf & "?"), vbLf & "?") - 在应用过滤器之前，您需要检查并删除任何先前存在的过滤器。
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: If the 'Selection' is a range and if its cells contain
' duplicates, it will use these duplicates to filter
' the active sheet's Excel table 'Table1' in its 3rd column.
' Calls: ArrMultiRangeDuplicates
' DictMultiRangeCount
' GetRange
' DictAddCount
' DictRemoveSingleCount
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FilterByDuplicatesExample()
Const ProcName As String = "FilterByDuplicatesExample"
On Error GoTo ClearError
If Not TypeOf Selection Is Range Then Exit Sub ' not a range
' Using the ArrMultiRangeDuplicates function and its accompanying procedures,
' write the Selection's duplicates to an array.
Dim Ary As Variant: Ary = ArrMultiRangeDuplicates(Selection)
If IsEmpty(Ary) Then Exit Sub
' Using the Split and Join functions, 'convert the array to text'.
Ary = Split(Join(Ary, vbLf & "?"), vbLf & "?")
'Debug.Print Join(Ary, ",")
' Apply the filter.
With ActiveSheet.ListObjects("Table1")
If .ShowAutoFilter Then ' remove possible previous filter
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
End If
.Range.AutoFilter Field:=3, Criteria1:=Ary, Operator:=xlFilterValues
End With
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Tests the ArrMultiRangeDuplicates function.
' In the active sheet, enter some values in a range
' starting from cell `A1`. Make sure there are duplicates.
' In the Immediate window (Ctrl+G) see the results.
' Calls: ArrMultiRangeDuplicates
' DictMultiRangeCount
' GetRange
' DictAddCount
' DictRemoveSingleCount
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ArrMultiRangeDuplicatesTEST()
Dim rg As Range: Set rg = Range("A1").CurrentRegion
Dim Arr As Variant: Arr = ArrMultiRangeDuplicates(rg)
If Not IsEmpty(Arr) Then
Debug.Print Join(Arr, ",")
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: From a (multi-) range ('mrg'), returns its cell's duplicates
' in an array.
' Remarks: Error values and blanks are excluded.
' Calls: DictMultiRangeCount
' GetRange
' DictAddCount
' DictRemoveSingleCount
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrMultiRangeDuplicates( _
ByVal mrg As Range) _
As Variant
Const ProcName As String = "ArrMultiRangeDuplicates"
On Error GoTo ClearError
' Return the unique values and their count, in a dictionary
Dim dict As Object: Set dict = DictMultiRangeCount(mrg)
If dict Is Nothing Then Exit Function
' Remove the values that occur only once from the dictionary.
DictRemoveSingleCount dict
If dict.Count = 0 Then Exit Function
' Return the dictionary keys.
ArrMultiRangeDuplicates = dict.Keys
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: From a (multi-) range ('mrg'), returns its cell's unique values
' and their count, in a dictionary.
' Remarks: Error values and blanks are excluded.
' Calls: GetRange,DictAddCount.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictMultiRangeCount( _
ByVal mrg As Range) _
As Object
Const ProcName As String = "ArrMultiRangeDuplicates"
On Error GoTo ClearError
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim arg As Range
Dim aData As Variant
Dim aKey As Variant
Dim acCount As Long
Dim ar As Long
Dim ac As Long
For Each arg In mrg.Areas
aData = GetRange(arg)
acCount = UBound(aData, 2)
For ar = 1 To UBound(aData) ' rows
For ac = 1 To acCount ' columns
aKey = aData(ar, ac)
DictAddCount dict, aKey ' write to the dictionary
Next ac
Next ar
Next arg
If dict.Count = 0 Then Exit Function
Set DictMultiRangeCount = dict
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') writing the number 1 to its associated item.
' If the key already exists, it increases its item's value by 1.
' Remarks: Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddCount( _
ByRef dict As Object, _
ByVal Key As Variant)
Const ProcName As String = "DictAddCount"
On Error GoTo ClearError
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = dict(Key) + 1 ' count
End If
End If
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In an existing ('ByRef') dictionary ('dict'), removes each key
' whose item's value is equal to a whole number ('KeyCount').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictRemoveSingleCount( _
ByRef dict As Object, _
Optional ByVal KeyCount As Long = 1)
Const ProcName As String = "DictRemoveSingleCount"
On Error GoTo ClearError
Dim Key As Variant
For Each Key In dict.Keys
If IsNumeric(dict(Key)) Then
If dict(Key) = KeyCount Then dict.Remove Key
End If
Next Key
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub