Existe uma macro para filtrar a tabela por alguns elementos da lista?

Question

Eu tenho uma tabela com entradas baseadas em uma lista e usei uma macro que encontrei em algum lugar para poder adicionar / remover vários elementos da lista para uma célula. Deixe-me mostrar um exemplo:

TEST TABLE
test1
test1, test2
test1, test3
test2, test3, test4

Onde os itens da lista são test1, test2 e assim por diante.

Agora, não sei se isso é possível, mas gostaria de poder filtrar instantaneamente a tabela por um item específico da lista (por exemplo, test1). Além disso, gostaria de colocar esses critérios em uma caixa de verificação. filtros para que em vez de caixas de seleção como "test1, test2" nas caixas de seleção eu teria apenas itens individuais da lista (como test1, test2 e assim por diante)

É mesmo possível, e se sim alguém pode ajudar a preparar uma macro para isso? Além disso, estou colocando aqui minha macro da pasta de trabalho:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
        lUsed = InStr(1, oldVal, newVal)
        If lUsed > 0 Then
            If Right(oldVal, Len(newVal)) = newVal Then
                Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
            Else
                Target.Value = Replace(oldVal, newVal & ", ", "")
            End If
        Else
            Target.Value = oldVal _
              & ", " & newVal
        End If

      End If
  End If
End If

exitHandler:
  Application.EnableEvents = True

Call AutoFitColumns

End Sub

Sub AutoFitColumns()
Dim rng As Range
Set rng = Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
rng.EntireColumn.AutoFit
End Sub

    

Answer 1

Embora este seja um post antigo, estou fornecendo uma maneira de fazer isso, como uma referência

• Crie um novo UserForm com o nome padrão "UserForm1"
• Crie um novo ComboBox com o nome padrão "ComboBox1" no formulário, semelhante a este

AdicioneestecódigoaomóduloVBAparaoformulário:

OptionExplicitPrivateenableEvtsAsBooleanPrivatethisColAsRangePrivateSubComboBox1_Change()IfenableEvtsThenfilterColumnthisCol,ComboBox1.Text'Me.HideEndSubPublicSubsetupList(ByRefcolAsRange)SetthisCol=colenableEvts=FalsesetListcol,ComboBox1enableEvts=TrueMe.Caption="Filter Column: " & Left(col.Address(, False), 1)
End Sub

Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
   If KeyAscii = vbKeyEscape Then Me.Hide
End Sub
Private Sub CommandButton1_Click()
   ComboBox1.ListIndex = -1
   If Not Sheet1.AutoFilter Is Nothing Then Sheet1.UsedRange.AutoFilter
End Sub
Private Sub CommandButton2_Click()
   Me.Hide
End Sub
Private Sub UserForm_Click()
   Me.Hide
End Sub

Cole este código no módulo VBA da Planilha1:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   With Target
      If .CountLarge = 1 Then
         removeAllFilters Me
         If .Row = 1 Then
            .Offset(1, 0).Activate
            UserForm1.setupList Me.UsedRange.Columns(.Column)
            UserForm1.Show
         End If
      End If
   End With
End Sub

dados da Folha1:

ColeestecódigoemummóduloVBApadrão(abraoVBA:Alt+F11,cliquenomenuInserir>Módulo)

OptionExplicitPublicSubsetList(ByRefrngAsRange,ByRefcmbAsComboBox)DimwsAsWorksheet,lstAsRange,lrAsLongIfrng.Columns.Count=1ThenxlEnabledFalseSetws=rng.ParentremoveAllFilterswsSetlst=ws.UsedRange.Columns(rng.Column)lr=getLastRow(lst,rng.Column)Iflr>1ThenWithcmb.List=Split(getDistinct(lst,lr),",")
            .ListIndex = -1
         End With
      End If
      xlEnabled True
   End If
End Sub

Public Sub xlEnabled(ByVal onOff As Boolean)
    Application.ScreenUpdating = onOff
    Application.EnableEvents = onOff
End Sub

Private Function getLastRow(ByRef rng As Range, ByVal lc As Long) As Long
   Dim ws As Worksheet, lr As Long
   If Not rng Is Nothing Then
      Set ws = rng.Parent
      lr = ws.Cells(rng.Row + ws.UsedRange.Rows.Count + 1, lc).End(xlUp).Row
      Set rng = ws.Range(ws.Cells(1, lc), ws.Cells(lr, lc)) 'updates rng (ByRef)
   End If
   getLastRow = lr
End Function

Private Function getDistinct(ByRef rng As Range, ByVal lr As Long) As String
   Dim ws As Worksheet, lst As String, lc As Long, tmp As Range, v As Variant, c As Double

   Set ws = rng.Parent
   lc = ws.Cells(rng.Row, rng.Column + ws.UsedRange.Columns.Count + 1).End(xlToLeft).Column
   Set tmp = ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1))

   If tmp.Count > 1 Then
      With tmp.Cells(1, 1)
         .Formula = "=Trim(" & ws.Cells(rng.Row, lc).Address(False, False) & ")"
         .AutoFill Destination:=tmp
      End With

      tmp.Value2 = tmp.Value2       'convert formulas to values
      tmp.Cells(1, 1).ClearContents 'remove header from list
      cleanCol tmp, lc
      lr = getLastRow(tmp, lc + 1)

      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      v = Application.Transpose(Split(lst, ","))

      lr = UBound(v)
      ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1)) = v
      getLastRow tmp, lc + 1

      cleanCol tmp, lc
      getLastRow tmp, lc + 1
      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      tmp.Cells(1, 1).EntireColumn.Clear
   End If
   getDistinct = lst
End Function

Public Sub filterColumn(ByRef col As Range, ByVal fltrCriteria As String)
   Dim ws As Worksheet, lst As Range, lr As Long

   xlEnabled False
   Set ws = col.Parent
   Set lst = ws.UsedRange.Columns(col.Column)
   lr = getLastRow(lst, col.Column)

   lst.AutoFilter
   lst.AutoFilter Field:=1, Criteria1:="*" & fltrCriteria & "*"
   xlEnabled True
End Sub

Private Sub cleanCol(ByRef tmp As Range, ByVal lc As Long)
   Dim ws As Worksheet, lr As Long

   Set ws = tmp.Parent
   tmp.RemoveDuplicates Columns:=1, Header:=xlNo
   lr = getLastRow(tmp, lc + 1)

   ws.Sort.SortFields.Add Key:=ws.Cells(lr + 1, lc + 1), Order:=xlAscending
   With ws.Sort
      .SetRange tmp
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .Apply
   End With
End Sub

Public Sub removeAllFilters(ByRef ws As Worksheet)

   If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter
   ws.Rows.Hidden = False

End Sub

Clicar na coluna do cabeçalho ("TEST TABLE") irá filtrar a lista em 2 partes

Parte 1:

• Extraia os itens de todas as células da coluna atual para a primeira coluna não utilizada da planilha
• Recorte todos os itens usando a fórmula do Excel TRIM () (não copiar usando a área de transferência)
• Remover duplicados da lista: .RemoveDuplicates Columns:=1, Header:=xlNo
• Classifique os itens no lugar (as palavras em cada célula ainda não estão separadas)
• Crie uma string contendo todo o texto, separado por vírgulas

Parte 2:

• Divida a string novamente
• Apare todos os itens (palavras de célula agora estão separadas e podem conter espaços extras)
• Remover duplicatas da lista e classificá-las mais uma vez
• Crie uma string final contendo a lista filtrada
• Atualize o menu suspenso da caixa de combinação com itens finais

Quando o usuário seleciona um item da lista suspensa

• Ele executará um filtro automático de células contendo texto parcial

  • Criteria1:="*" & fltrCriteria & "*" , (Ex "* test3 *" )

• Botão Limpar classificação remove o filtro automático

• O botão Cancelar fecha o formulário, sem remover o filtro

• Depois que o formulário é fechado, o filtro pode ser removido de 3 maneiras

  • A maneira padrão, usando o menu suspenso AutoFiltro e "Selecionar tudo"
  • Menu Guia Dados e clicando no botão Filtro
  • Clicando no cabeçalho da coluna novamente (TEST TABLE)

Lista suspensa Filtrada:

Linhasfiltradasusandoocritério"test3"

Limparofiltroanterior: