☰

選択範囲内の重複セルから配列を作成し、この配列をオートフィルタ条件として使用するための VBA1

tag-icon • tag-icon microsoft-excel vba
選択範囲内の重複セルから配列を作成し、この配列をオートフィルタ条件として使用するための VBA1

レンジとテーブルがあります。

範囲内の重複項目をチェックし、それらの項目をテーブルからフィルター処理したいのですが... 以下は私が実行した方法ですが、うまくいきません。

選択範囲内で重複する項目のリスト/配列/範囲を作成するコードを作成しました。

次に、このリスト/配列/範囲の複製を 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

Microsoft が教えてくれないこと パート 94...

フィルタリングする列が数値で構成されている場合であっても、メソッドで使用されるフィルタ基準値はAutofilterテキスト文字列として指定する必要があります。

配列の構築に使用する代入文をAry次のように変更します。

Ary(i) = CStr(cell.Value)

配列がテキスト文字列で構成されていることを確認します。

さらに良いのは、Ary文字列配列として宣言することです

Dim Ary() As String

Aryバリエーションとしてではなく、最初から意図が明確になるようにします。

ヒントはオートフィルタメソッドのドキュメント数値はテキスト文字列として基準引数に渡す必要があります (ドキュメントに記載されている 3 番目の例を参照)。ただし、この要件は強調されていません。

答え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

関連情報