Filtro Avançado
É possível realizar um filtro avançado com o código do Ralph do SOen, tirar o acento da palavra com o código do ExtendOffice e ignorar minúscula ou maiúscula transformando tupo em maiúscula com Ucase()
O filtro é realizado num formulário de nome Userform1, uma caixa de texto de nome TextBox1 e uma lista de nome ListBox1.
Código
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
Resultado
A letra é digitada no TextBox1 e o filtro é realizado, como é mostrado abaixo:
EDIT:
Multiselect
Há três opções de Multiselect:
ListBox.MultiSelect = 1
: Selecionar somente um elemento.
ListBox.MultiSelect = 2
: Clicar no item ou pressionar a barra de espaço para selecionar múltiplos itens
ListBox.MultiSelect = 3
: Pressione Shift e Ctrl para selecionar múltiplos itens
Código
Então o seguinte código é utilizado para alterar as configurações de setup ao iniciar o formulário.
Private Sub UserForm_Initialize()
'Entre outros códigos de inicialização
Me.ListBox1.MultiSelect = 1
End Sub
Botão de Filtrar Tabela Dinâmica
Um botão CommandButton
pode ser adicionado e após os dados serem escolhidos, estes serão filtrados na Tabela Dinâmica.
Código
A Função IsInArray()
do JimmyPena do SOen é utilizada.
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