☰

VBA для создания массива из дубликатов ячеек в выделенном фрагменте и использования этого массива в качестве критерия автофильтра1

tag-icon • tag-icon microsoft-excel vba
VBA для создания массива из дубликатов ячеек в выделенном фрагменте и использования этого массива в качестве критерия автофильтра1

У меня есть плита и стол.

Я хочу проверить наличие дубликатов элементов в диапазоне, а затем отфильтровать эти элементы из таблицы... ниже показано, что я сделал, но это не работает.

Я написал код для создания списка/массива/диапазона повторяющихся элементов в выборке.

Затем я передаю этот дубликат списка/массива/диапазона в Criteria1 autoFilter. Но это не работает. Он ничего не фильтрует.

' 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

То, о чем Microsoft вам не рассказывает, часть 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

Связанный контент