我有一個範圍和一張桌子。
我想檢查某個範圍內的重複項目，然後我想從表中過濾這些項目...下面是我所做的但不起作用。
我編寫了一個程式碼，用於在選擇中建立重複項目的清單/數組/範圍。
然後我將此清單/陣列/範圍重複傳遞給 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