Filter dynamic table by Listbox

Question

Private Sub Preencher().. From this publication here Filter dynamic table by word in a cell

... It is very efficient in searching column A ....

I would like to take the values that are in Listbox and apply them as filters in TD ...

(Active option Multiselect) and select in Listbox among the options that appeared which I want to apply the TD filter.

OR... Take all results and apply them to the TD filter...

It’s like this..

Private Sub TextBox1_Change()
textoDigitado = Range("$C$18").Text
Call PreencheLista
End Sub

Private Sub PreencheLista()
textoDigitado = TextBox1.Text
'código que irá filtrar os nomes
Dim linha As Integer
Dim TextoCelula As String
linha = 1
'limpa os dados do formulário
ListBox1.Clear
'Irá executar até o último nome
While ActiveSheet.Cells(linha, 1).Value <> Empty
'pega o nome atual
TextoCelula = ActiveSheet.Cells(linha, 1).Value
'quebra a palavra atual pela esquerda conforme a quantidade de letras digitadas e compara com o texto digitado
If InStr(UCase(TextoCelula), UCase(textoDigitado)) > 0 Then
'se a comparação for igual será adicionado no formulario
ListBox1.AddItem ActiveSheet.Cells(linha, 1)
End If
linha = linha + 1
Wend
End Sub

Answer 1

Advanced Filter

It is possible to perform an advanced filter with Soen’s Ralph code, remove the accent from the word with the Extendoffice code and ignore lowercase or uppercase by capitalizing the tuple with Ucase()

The filter is performed in a form named Userform1, a text box named Textbox1 and a list named Listbox1.

Code

Private Sub Textbox1_Change()
    'https://stackoverflow.com/a/42880069/7690982
    Dim i As Long
    Dim arrList As Variant
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Nome da Planilha")

    Me.ListBox1.Clear
    If ws.Range("A" & ws.Rows.Count).End(xlUp).Row > 1 And Trim(Me.TextBox1.Value) <> vbNullString Then
        arrList = ws.Range("A1:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row).Value2
        For i = LBound(arrList) To UBound(arrList)
            If InStr(1, UCase(StripAccent(CStr(arrList(i, 1)))), UCase(StripAccent(Trim(Me.TextBox1.Value))), vbTextCompare) Then
                Me.ListBox1.AddItem arrList(i, 1)
            End If
        Next i
    End If
    If Me.ListBox1.ListCount = 1 Then Me.ListBox1.Selected(0) = True

End Sub

Public Function StripAccent(thestring As String)
    'https://www.extendoffice.com/documents/excel/707-excel-replace-accented-characters.html
    Dim A As String * 1
    Dim B As String * 1
    Dim i As Integer
    Const AccChars = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
    Const RegChars = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
    For i = 1 To Len(AccChars)
        A = Mid(AccChars, i, 1)
        B = Mid(RegChars, i, 1)
        thestring = Replace(thestring, A, B)
    Next
    StripAccent = thestring
End Function

Upshot

The letter is typed in Textbox1 and the filter is performed as shown below:

EDIT:

Multiselect

There are three options of Multiselect:

• ListBox.MultiSelect = 1: Select only one element.
• ListBox.MultiSelect = 2: Click the item or press the space bar to select multiple items
• ListBox.MultiSelect = 3: Press Shift and Ctrl to select multiple items

Code

Then the following code is used to change the setup settings when starting the form.

Private Sub UserForm_Initialize()
    'Entre outros códigos de inicialização
    Me.ListBox1.MultiSelect = 1
End Sub

Filter Dynamic Table Button

A button CommandButton can be added and after the data is chosen, these will be filtered in the Dynamic Table.

Code

The Function IsInArray() of the Jimmypena of the Soen is used.

Private Sub CommandButton1_Click()
    Dim i As Long, j As Long
    Dim PvtTbl      As PivotTable
    Dim PvtItm      As PivotItem
    Dim ws As Worksheet
    Dim arr() As Variant
    On Error GoTo Sair
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Set ws = ThisWorkbook.Sheets("Nome da Planilha")
    Set PvtTbl = ws.PivotTables("Tabela dinâmica1")
    PvtTbl.ManualUpdate = True
    For i = 0 To ListBox1.ListCount - 1
        If Me.ListBox1.Selected(i) = True Then
            ReDim Preserve arr(j)
            arr(j) = Me.ListBox1.List(i)
            j = j + 1
        End If
    Next i

    With PvtTbl.PivotFields("campo")
        .ClearAllFilters
        For Each PvtItm In .PivotItems
            If IsInArray(PvtItm.Name, arr) = True Then
                PvtItm.Visible = True
            Else
                PvtItm.Visible = False
            End If
        Next PvtItm
    End With

Sair:
    Set PvtTbl = ws.PivotTables("Tabela dinâmica1")
    PvtTbl.ManualUpdate = False
    Debug.Print Err.Description
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
'https://stackoverflow.com/a/10952705/7690982
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function