☰

VBA zum Erstellen eines Arrays aus den doppelten Zellen in der Auswahl und Verwenden dieses Arrays als Autofilterkriterium1

tag-icon • tag-icon microsoft-excel vba
VBA zum Erstellen eines Arrays aus den doppelten Zellen in der Auswahl und Verwenden dieses Arrays als Autofilterkriterium1

Ich habe einen Herd und einen Tisch.

Ich möchte in einem Bereich nach doppelten Elementen suchen und diese Elemente dann aus der Tabelle filtern. Unten sehen Sie, was ich getan habe, aber es funktioniert nicht.

Ich habe einen Code zum Erstellen einer Liste/eines Arrays/eines Bereichs doppelter Elemente in der Auswahl geschrieben.

Dann übergebe ich dieses Duplikat der Liste/des Arrays/des Bereichs an das Kriterium1 des Autofilters. Aber es funktioniert nicht. Es filtert nichts.

' 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

Antwort1

Dinge, die Microsoft Ihnen nicht sagt, Teil 94 …

Die in der Methode verwendeten Filterkriterienwerte Autofiltermüssen als Textzeichenfolgen angegeben werden, auch wenn die Spalte, nach der Sie filtern, aus Zahlen besteht.

Ändern Sie die zum Erstellen des Arrays verwendete Zuweisungsanweisung Aryin

Ary(i) = CStr(cell.Value)

um sicherzustellen, dass das Array aus Textzeichenfolgen besteht.

Noch besser: Deklarieren Sie zusätzlich Aryein String-Array

Dim Ary() As String

und nicht als Variante, sodass die Absicht Aryvon Anfang an klar ist.

Es gibt einen Hinweis in derDokumentation zur Autofilter-Methodedass Zahlen als Textzeichenfolgen an die Kriterienargumente übergeben werden müssen (siehe das dritte in der Dokumentation aufgeführte Beispiel), diese Anforderung wird jedoch nicht betont.

Antwort2

Gibt eindeutige Duplikate in einem Array zurück

  • Der effizienteste (schnellste) Weg, die eindeutigen doppelten Werte in ein Array zu bekommen, wird normalerweise durch die Verwendung eines Wörterbuchs erreicht: Zuerst schreiben Sie alle Werte und ihre Anzahl hinein, dann durchlaufen Sie die Schlüssel im Wörterbuch und entfernen jeden Schlüssel, dessen Element den Wert 1 hat.
  • Um ein Array oder ein anderes Ergebnis zu „erhalten“, müssen Sie eine Funktion verwenden, die Sie
    z. B. von Ihrer Prozedur aus aufrufen Dim Ary As Variant: Ary = ArrMultiRangeDuplicates(Range("A1:A10,D5:d13").
  • Um ein Array in Text umzuwandeln, können Sie diesen einfachen Trick verwenden, den ich in Ihrem Unterbeispiel verwendet habe:
    Ary = Split(Join(Ary, vbLf & "?"), vbLf & "?")
  • Bevor Sie einen Filter anwenden, müssen Sie alle bereits vorhandenen Filter prüfen und entfernen.
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

verwandte Informationen