Excel "Smart" Dropdown / Проверка данных

Question

В Excel есть способ создать выпадающее меню или поле проверки данных, которое

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

Первым делом я попытался применить проверку данных к столбцу, установить его в список и установить источник списка в тот же столбец. Это позволяет достичь первых двух пунктов, но, к сожалению, при таком способе дублируется каждое значение каждый раз, когда оно используется в столбце (и это не очень хорошо сортирует список).

Любая помощь приветствуется!

Answer 1

Код ниже генерирует комбинированный список (проверка данных) и:

• Позволяет пользователям вводить значение, которого в данный момент нет в списке
• Добавляет все новые значения в раскрывающийся список
• Удаляет повторяющиеся записи
• Обрезает все значения в списке
• Сортирует список по алфавиту

Куда вставить код:

• Откройте редактор VBA: Alt + F11

  1. первый sub Worksheet_Change() должен быть вставлен в модуль VBA листа

• Все остальные подпрограммы и функции (разделы 1 и 2) должны быть вставлены в новый модуль VBA.

  2. в редакторе нажмите меню Вставка > Модуль и вставьте новый код

---

,

В модуле Sheet1 (объекты Microsoft Excel, в верхнем левом углу редактора VBA):

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Columns.Count = 1 Then setList Target
End Sub

---

,

1 из 2 (новый модуль VBA):

Option Explicit

Public Sub setList(ByRef rng As Range, Optional fullColumn As Boolean = True)
   Dim ws As Worksheet, lst As Range, lr As Long

   If rng.Columns.Count = 1 Then
      xlEnabled False
      Set ws = rng.Parent
      Set lst = ws.UsedRange.Columns(rng.Column)
      lr = setLastRow(lst, rng.Column)
      If lr > 1 Then
         If fullColumn Then Set lst = ws.Columns(rng.Column)
         With lst.Validation
            .Delete
            .Add Type:=xlValidateList, Formula1:=getDistinct(lst, lr)
            .ShowError = False
         End With
      End If
      xlEnabled True
   End If
End Sub

Private Function setLastRow(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
   setLastRow = lr
End Function

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

---

2 из 2:

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

   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
      tmp.RemoveDuplicates Columns:=1, Header:=xlNo
      lr = setLastRow(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

      setLastRow tmp, lc + 1
      lst = Join(Application.Transpose(tmp), ",")
      tmp.Cells(1, 1).EntireColumn.Delete
   End If

   getDistinct = lst

End Function

---

Всякий раз, когда вы вводите новое значение (в любом столбце)

• Код отключает ScreenUpdating и события (временно)
• Любая предыдущая проверка данных для текущего столбца будет удалена
• Он определяет последний использованный столбец на листе и последнюю ячейку с данными в текущем столбце.

• Он проверяет, должен ли раскрывающийся список применяться ко всему столбцу или только к ячейкам с данными.

  • Эта опция может быть переключена путем изменения fullColumn As Boolean = True на False

• Функция getDistinct ():

  • копирует все значения в текущем столбце в первый неиспользуемый столбец на листе
  • это не обычная операция копирования \ вставки
  • он применяет TRIM () в новом столбце для всех ячеек в текущем столбце
  • затем преобразует результаты формулы в строки
  • применяет RemoveDuplicates только к этому новому диапазону
  • применяется сортировка к оставшемуся списку
  • снова определяет размер списка и преобразует диапазон в строку элементов, разделенных запятыми

• Sub setList () применяет список к новому правилу проверки, которое генерирует раскрывающийся список

  • Это правило проверки можно удалить из «Данные»> «Проверка данных» (выберите столбец и «Очистить все»).

• Его можно отключить, закомментировав одну строку:

,

Private Sub Worksheet_Change(ByVal Target As Range)
   'If Target.Columns.Count = 1 Then setList Target
End Sub