☰

是否有一个宏可以通过一些列表元素来过滤表格？

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba macros
是否有一个宏可以通过一些列表元素来过滤表格？

我有一张基于列表的条目表，并且我使用了在某处找到的宏来将列表中的多个元素添加/删除到一个单元格，让我给你举个例子：

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

列表中的项目是 test1、test2 等等。

现在我不知道这是否可行，但我希望能够立即按列表中的特定项目过滤表格（例如 test1），此外，我想将这些条件放在复选框过滤器中，这样，在复选框中我就不会有“test1，test2”这样的复选框，而只会有列表中的单个项目（如 test1、test2 等等）

这有可能吗？如果可以，有人能帮忙准备一个宏吗？另外，我将工作簿中的宏放在这里：

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

答案1

虽然这是一篇旧帖子，但我提供了一种方法，作为参考

  • 创建一个新的用户窗体，默认名称为“UserForm1”
  • 在表单上创建一个新的 ComboBox，默认名称为“ComboBox1”，类似于此

在此处输入图片描述

将此代码添加到表单的 VBA 模块中：

Option Explicit

Private enableEvts As Boolean
Private thisCol As Range

Private Sub ComboBox1_Change()
   If enableEvts Then filterColumn thisCol, ComboBox1.Text
   'Me.Hide
End Sub

Public Sub setupList(ByRef col As Range)
   Set thisCol = col
   enableEvts = False
      setList col, ComboBox1
   enableEvts = True
   Me.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

将此代码粘贴到 Sheet1 的 VBA 模块中：

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

Sheet1 数据：

在此处输入图片描述

将此代码粘贴到标准 VBA 模块中（打开 VBA：Alt+ F11，单击菜单插入>模块）

Option Explicit

Public Sub setList(ByRef rng As Range, ByRef cmb As ComboBox)
   Dim ws As Worksheet, lst As Range, lr As Long

   If rng.Columns.Count = 1 Then
      xlEnabled False
      Set ws = rng.Parent
      removeAllFilters ws
      Set lst = ws.UsedRange.Columns(rng.Column)
      lr = getLastRow(lst, rng.Column)

      If lr > 1 Then
         With cmb
            .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

单击标题列（“测试表”）将列表分为两部分

第1部分：

  • 将当前列所有单元格中的项目提取到工作表的第一个未使用的列中
  • 使用 Excel TRIM() 公式修剪所有项目（而不是使用剪贴板复制粘贴）
  • 从列表中删除重复项：.RemoveDuplicates Columns:=1, Header:=xlNo
  • 按原位对项目进行排序（每个单元格中的单词尚未分开）
  • 创建一个包含所有文本的字符串，以逗号分隔

第2部分：

  • 再次分割字符串
  • 修剪所有项目（单元格单词现在分开并且可以包含额外的空格）
  • 从列表中删除重复项并再次排序
  • 创建包含过滤列表的最终字符串
  • 使用最终项目更新组合框下拉菜单

当用户从下拉列表中选择一个项目时

  • 它将对包含部分文本的单元格执行自动过滤

    • Criteria1:="*" & fltrCriteria & "*"， （前任“*测试3*”）

  • 按钮清除排序删除自动筛选

  • 按钮取消关闭表单，但不删除过滤器

  • 表单关闭后，可以通过 3 种方式删除过滤器

    • 标准方法，使用自动筛选下拉菜单和“全选”
    • 菜单数据选项卡并点击筛选按钮
    • 再次单击列标题（测试表）

过滤后的下拉列表：

在此处输入图片描述

使用条件“test3”过滤行

在此处输入图片描述

清除上一个过滤器：

在此处输入图片描述

相关内容