1

У меня есть таблица с записями на основе списка, и я использовал макрос, который я нашел где-то, чтобы иметь возможность добавлять / удалять несколько элементов из списка в одну ячейку, позвольте мне показать вам пример:

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

Где элементы из списка - test1, test2 и т.д.

Сейчас я не знаю, возможно ли это вообще, но я хотел бы иметь возможность мгновенно фильтровать таблицу по конкретному элементу из списка (например, test1), более того, я бы хотел поместить эти критерии в фильтры chceckbox, чтобы вместо флажков типа «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 ответ1

0

Несмотря на то, что это старый пост, я предоставляю один из способов сделать это, в качестве ссылки

  • Создайте новую пользовательскую форму с именем по умолчанию "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

Вставьте этот код в модуль VBA для Sheet1:

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

Данные листа1:

Вставьте этот код в стандартный модуль 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

Нажатие на столбец заголовка ("TEST TABLE") отфильтрует список в 2 части

Часть 1:

  • Извлечь элементы из всех ячеек текущего столбца в первый неиспользуемый столбец листа
  • Обрезать все элементы, используя формулу Excel TRIM() (без копирования с использованием буфера обмена)
  • Удалить дубликаты из .RemoveDuplicates Columns:=1, Header:=xlNo
  • Сортировка элементов на месте (слова в каждой ячейке еще не разделены)
  • Создайте одну строку, содержащую весь текст, разделенный запятыми

Часть 2:

  • Снова разделить строку
  • Обрезать все элементы (теперь ячейки разделены и могут содержать лишние пробелы)
  • Удалить дубликаты из списка и отсортировать их еще раз
  • Создайте одну последнюю строку, содержащую отфильтрованный список
  • Обновить выпадающий список со списком

Когда пользователь выбирает элемент из выпадающего списка

  • Он выполнит автофильтр для ячеек, содержащих частичный текст

    • Criteria1:="*" & fltrCriteria & "*" , (например, "* test3 *")

  • Кнопка Clear Sort удаляет автофильтр

  • Кнопка Отмена закрывает форму, не снимая фильтр

  • После того, как форма закрыта, фильтр можно удалить 3 способами

    • Стандартный способ, используя раскрывающийся список Автофильтр и "Выбрать все"
    • Вкладка «Данные меню» и нажатие кнопки « Фильтр»
    • Снова нажмите на заголовок столбца (TEST TABLE)

Отфильтрованный раскрывающийся список:

Отфильтрованные строки по критерию "test3"

Очистить предыдущий фильтр:

|источник

Всё ещё ищете ответ? Посмотрите другие вопросы с метками .