Multiple cells AutoFilter-CodePudding

I have a code that selects non empty cells in column C. Now If I want to select these cells in my autofilter it only pics the first found value of OutRng. How do i fix this?

Sub SelectNonBlankCells()

    Sheets("Rekenblad").Select

    Dim Rng As Range
    Dim OutRng As Range
    Dim xTitle As String
    SearchCol = "10"

    On Error Resume Next

    xTitle = Range("C:C")
    Set InputRng = Range("C:C")

    For Each Rng In InputRng
        If Not Rng.Value = "" Then
            If OutRng Is Nothing Then
                Set OutRng = Rng
            Else
                Set OutRng = Application.Union(OutRng, Rng)
            End If
        End If
    Next

    If Not (OutRng Is Nothing) Then
        OutRng.Copy

        Sheets("Plakken").Select
        ActiveSheet.Range("$A$1:$K$13").AutoFilter Field:=10, Criteria1:=Array(OutRng) _
            , Operator:=xlFilterValues
    End If
End Sub

CodePudding user response：

AutoFilter on Multiple (an Array of) Values

Range("C:C") is quite a huge range and it could take ages to get processed.
OutRng.Copy makes no sense unless you plan to copy it somewhere.
Since OutRng is declared as a range, Array(OutRng) is an array containing one element which is the actual range (object, not values).
If a range contains more than one cell and is contiguous (a single range, one area), you can use OutRng.Value but this is a 2D one-based array which in this case (it's one-column array) could be converted to a 1D one-based array using Application.Transpose(OutRng.Value) with its limitations. But since you have combined various cells into a range, it is expected that the range is non-contiguous (has several areas, is a multi-range), you're again at a dead end.
No matter what, it was an interesting try (IMHO).

Option Explicit

Sub FilterRange()
    
    ' Source
    Const sName As String = "Rekenblad"
    Const sCol As String = "C"
    Const sfRow As Long = 2
    ' Destination
    Const dName As String = "Plakken"
    Const dField As Long = 10
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the Source Range ('srg').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    'If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow   1
    If srCount < 1 Then Exit Sub ' no data
    Dim srg As Range: Set srg = sws.Cells(sfRow, sCol).Resize(srCount)
    
    ' Write the values from the Source Range to the Source Array ('sData').
    Dim sData As Variant
    If srCount = 1 Then ' one cell
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else ' multiple cells (in column)
        sData = srg.Value
    End If
    
    ' Write the unique values from the Source Array to the keys
    ' of a dictionary ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' A = a
    Dim Key As Variant
    Dim r As Long
    For r = 1 To srCount
        Key = sData(r, 1)
        If Not IsError(Key) Then ' not error value
            If Len(Key) > 0 Then ' not blank
                dict(CStr(Key)) = Empty
            'Else ' blank
            End If
        ' Else ' error value
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only blanks and error values

    ' Filter the Destination Range ('drg') by the values in the dictionary.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    If dws.AutoFilterMode Then dws.AutoFilterMode = False ' remove previous
    Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion
    ' If the previous line doesn't work, use another way,
    ' or revert to the static:
    'Set drg = dws.Range("A1:K13")
    drg.AutoFilter dField, dict.Keys, xlFilterValues
    'dws.activate

End Sub

CodePudding user response：

I think you got to pass you range value into an array :

cpt = 0
For Each cell In OutRng 
    ReDim Preserve MyArray(cpt)
    MyArray(cpt) = cell.Text
    cpt= cpt  1
Next

Sheets("Plakken").Range("$A$1:$K$13").AutoFilter Field:=10, Criteria1:=MyArray _
            , Operator:=xlFilterValues