☰

VBA para crear una matriz a partir de las celdas duplicadas en la selección y usar esta matriz como criterio de autofiltro1

tag-icon • tag-icon microsoft-excel vba
VBA para crear una matriz a partir de las celdas duplicadas en la selección y usar esta matriz como criterio de autofiltro1

Tengo una estufa y una mesa.

Quiero verificar si hay elementos duplicados en un rango y luego quiero filtrar estos elementos de la tabla... a continuación se muestra lo que hice pero no funcionó.

He escrito un código para hacer una lista/matriz/rango de elementos duplicados en la selección.

Luego paso este duplicado de lista/matriz/rango al Criterio1 de autoFilter. Pero no funciona. no filtra nada.

' 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

Respuesta1

Cosas que Microsoft no te cuenta Parte 94...

Los valores de los criterios de filtro utilizados en el Autofiltermétodo deben especificarse como cadenas de texto, incluso si la columna que está filtrando comprende números.

Cambie su declaración de asignación utilizada para construir la Arymatriz a

Ary(i) = CStr(cell.Value)

para garantizar que la matriz comprenda cadenas de texto.

Aún mejor, declara adicionalmente Arycomo una matriz de cadenas

Dim Ary() As String

y no como una variante, por lo que la intención Aryqueda clara desde el principio.

Hay una pista en eldocumentación para el método Autofiltroque los números deben pasarse a los argumentos de criterios como cadenas de texto (consulte el tercer ejemplo enumerado en la documentación), pero no se enfatiza este requisito.

Respuesta2

Devolver duplicados únicos en una matriz

  • La forma más eficiente (más rápida) de obtener los valores duplicados únicos en una matriz generalmente se logra mediante el uso de un diccionario: primero se escriben todos los valores y su recuento y luego se recorre las claves en el diccionario y se elimina cada clave cuyo El artículo tiene un valor de 1.
  • Para 'obtener' una matriz o cualquier otro resultado, debe usar una función que llamará desde su procedimiento,
    por ejemplo Dim Ary As Variant: Ary = ArrMultiRangeDuplicates(Range("A1:A10,D5:d13").
  • Para 'convertir una matriz en texto' puedes usar este sencillo truco que utilicé en tu subejemplo:
    Ary = Split(Join(Ary, vbLf & "?"), vbLf & "?")
  • Antes de aplicar un filtro, debe verificar y eliminar cualquier filtro existente previamente.
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

información relacionada