☰

선택 항목의 중복 셀에서 배열을 만들고 이 배열을 자동 필터 기준으로 사용하기 위한 VBA

tag-icon • tag-icon microsoft-excel vba
선택 항목의 중복 셀에서 배열을 만들고 이 배열을 자동 필터 기준으로 사용하기 위한 VBA

레인지와 테이블이 있어요.

범위에서 중복 항목을 확인한 다음 테이블에서 이러한 항목을 필터링하고 싶습니다. 아래는 제가 수행한 작업이지만 작동하지 않습니다.

선택 항목에서 중복 항목의 목록/배열/범위를 만드는 코드를 작성했습니다.

그런 다음 이 목록/배열/범위 중복을 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

마이크로소프트가 당신에게 말하지 않은 것들 Part 94...

Autofilter필터링하는 열이 숫자로 구성된 경우에도 메서드 에 사용되는 필터 기준 값은 텍스트 문자열로 지정되어야 합니다.

배열 을 구축하는 데 사용된 할당문을 Ary다음으로 변경하세요.

Ary(i) = CStr(cell.Value)

배열이 텍스트 문자열로 구성되어 있는지 확인합니다.

더 나은 방법은 추가로 Ary문자열 배열로 선언하는 것입니다.

Dim Ary() As String

변형이 아니라 Ary처음부터 의도가 분명합니다.

에 힌트가 있습니다Autofilter 메소드에 대한 문서숫자는 텍스트 문자열로 기준 인수에 전달되어야 합니다(문서에 나열된 세 번째 예 참조). 그러나 이 요구 사항은 강조되지 않습니다.

답변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

관련 정보