Có một macro để lọc bảng theo một số thành phần danh sách?

Tôi có một bảng với các mục dựa trên danh sách và tôi đã sử dụng một macro mà tôi tìm thấy ở đâu đó để có thể thêm / xóa nhiều phần tử khỏi danh sách vào một ô, để tôi chỉ cho bạn một ví dụ:

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

Trong đó các mục từ danh sách là test1, test2, v.v.

Bây giờ tôi không biết điều này có khả thi hay không, nhưng tôi muốn có thể ngay lập tức lọc bảng theo mục cụ thể từ danh sách (ví dụ test1), hơn nữa tôi muốn đưa các tiêu chí này vào bộ lọc chceckbox để thay vì các hộp kiểm như "test1, test2" trong các hộp kiểm tôi sẽ chỉ có các mục duy nhất từ ​​danh sách (như test1, test2, v.v.)

Thậm chí là có thể, và nếu có ai đó có thể giúp chuẩn bị một macro cho việc này không? Ngoài ra, tôi đang đặt ở đây macro của tôi từ sổ làm việc:

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

Mặc dù đây là một bài viết cũ, tôi đang cung cấp một cách để làm nó, như một tài liệu tham khảo

• Tạo một UserForm mới với tên mặc định "UserForm1"
• Tạo một ComboBox mới với tên mặc định "ComboBox1" trên biểu mẫu, tương tự như thế này

Thêm mã này vào mô-đun VBA cho Biểu mẫu:

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

Dán mã này vào mô-đun VBA cho Trang tính 1:

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

Dữ liệu trang tính 1:

Dán mã này vào mô-đun VBA tiêu chuẩn (mở VBA: Alt+ F11, nhấp vào menu Chèn> Mô-đun)

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

Nhấp vào cột tiêu đề ("BẢNG KIỂM TRA") sẽ lọc danh sách thành 2 phần

Phần 1:

• Trích xuất các mục từ tất cả các ô của cột hiện tại vào cột không sử dụng đầu tiên của trang tính
• Cắt tất cả các mục, sử dụng công thức Excel TRIM () (không sao chép bằng cách sử dụng bảng tạm)
• Xóa các bản sao khỏi danh sách: .RemoveDuplicates Columns:=1, Header:=xlNo
• Sắp xếp các mục tại chỗ (các từ trong mỗi ô chưa được phân tách)
• Tạo một chuỗi chứa tất cả văn bản, được phân tách bằng dấu phẩy

Phần 2:

• Tách chuỗi một lần nữa
• Cắt tất cả các mục (các từ ô hiện được phân tách có thể chứa thêm khoảng trắng)
• Xóa các bản sao khỏi danh sách và sắp xếp chúng một lần nữa
• Tạo một chuỗi cuối cùng chứa danh sách đã lọc
• Cập nhật hộp thả xuống với các mục cuối cùng

Khi người dùng chọn một mục từ danh sách thả xuống

• Nó sẽ thực hiện Bộ lọc tự động cho các ô chứa văn bản một phần

  • Criteria1:="*" & fltrCriteria & "*", (Ví dụ "* test3 *" )

• Nút Clear Sort loại bỏ Bộ lọc tự động

• Nút Hủy đóng biểu mẫu mà không xóa bộ lọc

• Khi biểu mẫu được đóng, bộ lọc có thể được gỡ bỏ 3 cách

  • Cách tiêu chuẩn, sử dụng trình đơn thả xuống Tự động lọc và "Chọn tất cả"
  • Menu Data Tab và nhấp vào nút Bộ lọc
  • Nhấp vào tiêu đề cột một lần nữa (BẢNG KIỂM TRA)

Danh sách thả xuống được lọc:

Các hàng được lọc sử dụng tiêu chí "test3"

Xóa bộ lọc trước: