================================================== Изначально эта была тема об альтернативе инструменту "Выпадающий список с автопоиском" из версии PLEX 2019.1 от 10 августа 2019 г., но после было решено обобщить тему до принципа работы формы (передача, поиск и возврат данных).
Спасибо всем, кто помогал и продолжает это делать на нашем любимом форуме! Отдельная благодарность за постоянные улучшения и объяснения Alemox Изменение, адаптация и усовершенствования формы под конкретные задачи - в личку
ОБЩИЙ ПРИНЦИП ДЕЙСТВИЯ 1. при запуске макроса, берутся все ячейки столбца кроме пустых (длина строки = 0) и ячеек-прочерков (значение ячейки = СИМВОЛ(151)) 2. Формируется одномерный массив (LBound=0) уникальных значений 3. Массив сортируется и выводится в форму 4. В строке поиска (маска) из служебных символов работает только "*" (любое количество любых символов). Остальные («arrSym()») будут удалены. 5. Маска по-умолчанию ищет БЕЗ учёта регистра и по всей строке: маска = "*" & маска & "*" 6. Наличие ведущей "*" можно регулировать кнопкой "искать по всей строке" 7. В активную ячейку можно вставить одно или несколько (будут сцеплены через "; ") значений 8. Выделить несколько значений можно, зажав ЛКМ или через Ctrl. Работает отмена выделения. 9. Можно ничего не выделить, тогда будет предложено вставить ВСЁ, что отсеяно маской (видно в окне) на текущий момент
ЧТО НУЖНО ДЛЯ РАБОТЫ: скопировать модуль и форму (перетащить мышью в редакторе) из файла-примера у свой
ПРИМЕР ВЫЗОВА: "ФормаПоискаПоАктивномуСтолбцу". В данном файле срабатывает по даблклику (событие листа)
Модуль
Код
Option Explicit
Public FS_arr, FS_Mask$
'===========================================================================================
Sub ФормаПоискаПоАктивномуСтолбцу()
Dim x, arrCol, arr1x(), dic As Object, rng As Range, r&
Set rng = Selection.Cells(1, 1)
r = Cells(Rows.Count, rng.Column).End(xlUp).Row
If r = 1 Then MsgBox "В столбце «" & rng.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
arrCol = Cells(1, rng.Column).Resize(r).Value2
Set dic = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(arrCol, 1)
If Len(arrCol(r, 1)) Then
If arrCol(r, 1) <> "—" Then
x = dic.Item(arrCol(r, 1))
End If
End If
Next r
If dic.Count = 0 Then MsgBox "В столбце «" & rng.Column & "» нет подходящих значений!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
arr1x = dic.Keys: dic.RemoveAll
If Not FS_Start(arr1x) Then Exit Sub
If UBound(arr1x) = 0 Then
rng.Value2 = arr1x(0)
Else
rng.Value2 = Join(arr1x, "; ")
End If
End Sub
'===========================================================================================
Function FS_Start(tmpArr()) As Boolean
Array1xSort tmpArr, 0, UBound(tmpArr)
FS_arr = tmpArr
Erase tmpArr
FS.Show
If Not IsArray(FS_arr) Then Exit Function
tmpArr = FS_arr
Erase FS_arr
FS_Start = True
End Function
'===========================================================================================
Sub Array1xSort(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then Array1xSort arr1x, l, j
If i < u Then Array1xSort arr1x, i, u
End Sub
'===========================================================================================
Форма
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
Private Sub bC_Click()
Dim arr(), x, i&, n&
ReDim arr(UBound(arrFull)): n = -1
For i = 0 To Me.lb.ListCount - 1
If Me.lb.Selected(i) Then n = n + 1: arr(n) = Me.lb.List(i)
Next i
If n = -1 Then
If MsgBox("Ничего не выбрано…" & vbLf & "Сформировать список из ВСЕГО ВИДИМОГО?", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
ReDim arr(0 To UBound(arrFull)): n = -1
For Each x In Me.lb.List
n = n + 1: arr(n) = x
Next x
End If
ReDim Preserve arr(n): FS_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
Private Sub lb_Click()
Me.lb.Selected(Me.lb.ListIndex) = Not Me.lb.Selected(Me.lb.ListIndex)
End Sub
'===========================================================================================
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
Me.bC.Visible = False
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out: Me.tb_count.Value = Me.lb.ListCount: Me.tb_mask.SetFocus: If Me.lb.ListCount > 0 Then Me.bC.Visible = True
End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Вдохновлён автором сайта (обновление PLEX), обучен на данном форуме
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Обновление или просто ещё вариант 1. форма переделана для выбора ОДНОГО значения из списка даблкликом 2. ускорен цикл сбора данных за счёт For Each 3. убрана проверка на прочерк (=СИМВОЛ(160)). Кажется, только я их использую 4.Value2 заменён на Value, чтобы более корректно отображалась дата (со временем сложнее) 5. запуск макроса по даблклику теперь "повешен" на всю книгу и сработает в любом месте
Модуль
Код
Option Explicit
Option Private Module
Public FS_arr, FS_Mask$
'===========================================================================================
Sub ФормаПоискаПоАктивномуСтолбцу()
Dim x, arr1x(), dic As Object, cl As Range, r&, t!
t = Timer
Set cl = ActiveCell
r = Cells(Rows.Count, cl.Column).End(xlUp).Row
If r < 3 Then MsgBox "В столбце «" & cl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
Set dic = CreateObject("Scripting.Dictionary")
For Each x In Cells(2, cl.Column).Resize(r).Value
If Len(x) Then x = dic.Item(x)
Next x
If dic.Count = 0 Then MsgBox "В столбце «" & cl.Column & "» нет подходящих значений!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
arr1x = dic.Keys: dic.RemoveAll
If Not FS_Start(arr1x) Then Exit Sub
cl.Value2 = arr1x(0)
End Sub
'===========================================================================================
Private Function FS_Start(tmpArr()) As Boolean
Array1xSort tmpArr, 0, UBound(tmpArr)
FS_arr = tmpArr
Erase tmpArr
FormSearch.Show
If Not IsArray(FS_arr) Then Exit Function
tmpArr = FS_arr
Erase FS_arr
FS_Start = True
End Function
'===========================================================================================
Private Sub Array1xSort(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then Array1xSort arr1x, l, j
If i < u Then Array1xSort arr1x, i, u
End Sub
'===========================================================================================
Форма
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.Value)
Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out: Me.tb_count.Value = Me.lb.ListCount: Me.tb_mask.SetFocus
End Sub
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, круто. Заметил небольшой неудобный или удобный (кому как) нюанс. - Вызываем форму пишем например "тру" - Выбираем любую строку щёлкаем по ней она вставляется - Опять вызываем фору - там уже написано "тру" - пишу вместо тру "хол" - нажимаю Esc - Вместо выхода из формы появляется "тру" - нажимаю ещё раз Esc и уже выхожу
Если так задумано, то ладно, коли нет, то можно решить эту проблему запихав Esc в другую процедуру
Код
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
End Sub
Ещё для удобства сделать Форму, чтобы мошой растягивать на нужный размер за уголок или за край. (в примере реализовал в приложении). Тем самым исчезает проблема с горизантальной прокруткой которую обрезает. В примере Esc перекинул тоже.
Ещё когда набираешь в строке поиска, до результатов приходится рукой тянуться. Удобнее нажать стрелку вниз и ты сразу по Listbox перемещаешься. (В примере реализовал). Ну и коли мыша мешает когда выбрал охото нажать Enter, а не два раза клацать по дохляку. (тоже в примере реализовал).
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
vikttur, я думаю это что-то типа такого P - (Paste) вставка a - (Active) в активную R - (Row) строку A - (alternative) альтернативных D - (data) данных o - (overnight) внезапно X - Либо версия 10, либо от слова Xerox - скопировано из базы данных
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
это был баг, а не фича благодарю за отзыв, поправки и "допиленную" версию — если не все, то большинство точно приму в работу P.S.: расшифровка никнейма - бомба UPD: отловил ошибку при при растягивании формы (слишком сильно сужение; см. скрин). Поправлю не раньше завтра/послезавтра (не сталкивался, но, думаю, ничего сложного)…
это мой никнейм ващет)) как-то хотел и тут сменить, но сошлись (с вами или с Юрием) на том, что не стоит. В названии темы фигурирует, потому что это не просто моя тема, а вроде готового решения. По нему будет всегда просто их найти
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
. Да, слишком увлекаться не надо. Обычно ставлю ограничение. Тут просто как пример не стал. Добавить надо ограничение на минимальный размер UsrForm.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Jack Famous: В названии темы фигурирует, потому что это не просто моя тема, а вроде готового решения. По нему будет всегда просто их найти
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Джек, другие пользователи будут искать по нику, который никому ничего не говорит или по задаче? Если Вы про свой поиск - добавьте тему в своё избранное. Удивляюсь, что нужно Вам это объяснять...
Доброго времени суток. Макрос не плохой, работает быстро и только... Для чего он предназначен - не понятно. Вот если он фильтровал по выбору сразу данные на активном листе - вот тогда да, БОМБА!!! Как правило приходится изгаляться в больших таблицах это сделать. А так вставить отфильтрованное... это можно и простым копированием... И еще.... в Вашу таблицу вставил 50 000 строк с текстом, так вот макрос по двойному клику не работает на вставленных строках, а только на изначальных, хотя уже в окне макроса вставленные строки видны и поиск работает. Как вставить больше одной позиции так и не понял: ЛКМ не удалось выделить, через CTRL не работает....
Юрий М: другие пользователи будут искать по нику, который никому ничего не говорит или по задаче?
по нику мной создано немало тем, а тех, что с "готовым решением" пока только одна. Таким образом, указание моего основного никнейма, используемого в том числе при разработке, даёт очень важный тэг для поиска. Считаю это важным для порядка. Абсолютно не против, если вы перенесёте PaRADoX из названия темы в описание (вторая строка при создании темы), но как по мне и так неплохо
достаточно прочитать название темы "Поиск и вставка значений в активном столбце"
Цитата
voxik-24: Вот если он фильтровал по выбору сразу данные на активном листе - вот тогда да, БОМБА
см. пункт 1 - название темы. К слову, его очень легко можно "прикрутить" для фильтрации - у меня как раз одна из таблиц имеет такой инструмент на основе этой формы
Цитата
voxik-24: в Вашу таблицу вставил 50 000 строк с текстом…
всё нормально работает, если использовать по назначению. Потрудитесь прочитать 2 первых поста и поймёте, что есть 2 версии, немало отличающиеся друг от друга. Подозреваю, что вы используете 2ю версию для ОДИНОЧНОГО выбора, ожидая функционала первой версии…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
БМВ, тогда скиньте в личку, а я позволю себе сей рисковый шаг
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Alemox, решил пока не лезть в API. Саму возможность подметил - спасибо, но в эту форму включать не буду. Кто захочет, поставит.
По остальному (форма с одиночным выбором): • изменил имя сортировки (в модуле) для однообразного вызова • использовал все ваши рекомендации и добавил выход с ввода на список не только по стрелке вниз, но и по стрелке вверх • изменил TabIndex элементов формы на "ввод-список-кнопка-количество найденных" • не зная, как побороть коварный Enter в окне ввода. Хотел провесить на него очистку, но при любом событии он перескакивает на следующий Tab-index. В принципе, достаточно просто его не использовать, но будет круто, если подскажете)))
Модуль
Код
Option Explicit
Option Private Module
Public FS_arr, FS_Mask$
'===========================================================================================
Sub ФормаПоискаПоАктивномуСтолбцу()
Dim x, arr1x(), dic As Object, cl As Range, r&, t!
t = Timer
Set cl = ActiveCell
r = Cells(Rows.Count, cl.Column).End(xlUp).Row
If r < 3 Then MsgBox "В столбце «" & cl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
Set dic = CreateObject("Scripting.Dictionary")
For Each x In Cells(2, cl.Column).Resize(r).Value
If Len(x) Then x = dic.Item(x)
Next x
If dic.Count = 0 Then MsgBox "В столбце «" & cl.Column & "» нет подходящих значений!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
arr1x = dic.Keys: dic.RemoveAll
If Not FS_Start(arr1x) Then Exit Sub
cl.Value2 = arr1x(0)
End Sub
'===========================================================================================
Private Function FS_Start(tmpArr()) As Boolean
FS_Sort tmpArr, 0, UBound(tmpArr)
FS_arr = tmpArr
Erase tmpArr
FormSearch.Show
If Not IsArray(FS_arr) Then Exit Function
tmpArr = FS_arr
Erase FS_arr
FS_Start = True
End Function
'===========================================================================================
Private Sub FS_Sort(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FS_Sort arr1x, l, j
If i < u Then FS_Sort arr1x, i, u
End Sub
'===========================================================================================
Форма
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.Value)
Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out: Me.tb_count.Value = Me.lb.ListCount: Me.tb_mask.SetFocus
End Sub
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 38 Or KeyCode = 40 Then lb.SetFocus
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
If KeyAscii = 13 Then
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.Value)
Unload Me
End If
End Sub
'===========================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
2 формы в одном файле: • 2 формы с индивидуальными кодами внутри • универсальный вызов любой с помощью необязательного параметра для формы с мультивыбором. Один модуль для обработки обеих форм. • выбор разделителя вызове формы с мультивыбором. В примере выбран " | " вместо "; " — по-умолчанию • в обеих формах учтены все плюшки от Alemox (кроме растягивания). Подробнее в предыдущем пункте + дублирование Enter'ом клавиши "ГОТОВО" — для формы с мультивыбором
Модуль книги (вызов любой формы)
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim bT As Byte: Cancel = True
bT = MsgBox("Вызвать форму для ОДИНОЧНОГО выбора…?" & vbLf & vbLf & Space$(5) & "• [ДА] — для ОДИНОЧНОГО выбора" & vbLf & Space$(5) & "• [НЕТ] — для МНОЖЕСТВЕННОГО выбора", vbYesNoCancel + vbQuestion + vbDefaultButton1)
If bT = vbYes Then
ФормаПоискаПоАктивномуСтолбцу
ElseIf bT = vbNo Then
ФормаПоискаПоАктивномуСтолбцу True, " | "
End If
End Sub
'===========================================================================================
Форма с мультивыбором
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
Private Sub bC_Click()
Dim arr(), x, i&, n&
ReDim arr(UBound(arrFull)): n = -1
For i = 0 To Me.lb.ListCount - 1
If Me.lb.Selected(i) Then n = n + 1: arr(n) = Me.lb.List(i)
Next i
If n = -1 Then
If MsgBox("Ничего не выбрано…" & vbLf & "Сформировать список из ВСЕГО ОТФИЛЬТРОВАННОГО" & vbLf & "(" & Me.lb.ListCount & " элементов)?", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
ReDim arr(0 To UBound(arrFull)): n = -1
For Each x In Me.lb.List
n = n + 1: arr(n) = x
Next x
End If
ReDim Preserve arr(n): FS_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
Private Sub lb_Click()
Me.lb.Selected(Me.lb.ListIndex) = Not Me.lb.Selected(Me.lb.ListIndex)
End Sub
'===========================================================================================
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
Me.bC.Visible = False
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out:
Me.tb_count.Value = Me.lb.ListCount
Me.tb_mask.SetFocus
If Me.lb.ListCount > 0 Then Me.bC.Visible = True
End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 38 Or KeyCode = 40 Then lb.SetFocus
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
If Me.lb.ListCount = 0 Then MsgBox "Список пуст!", vbExclamation, "ПУСТО": Exit Sub
bC_Click
End If
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Форма для одиночного выбора
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.Value)
Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out: Me.tb_count.Value = Me.lb.ListCount: Me.tb_mask.SetFocus
End Sub
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 38 Or KeyCode = 40 Then lb.SetFocus
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
If KeyAscii = 13 Then
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.Value)
Unload Me
End If
End Sub
'===========================================================================================
Модуль для обработки
Код
Option Explicit
Option Private Module
Public FS_arr, FS_Mask$
'===========================================================================================
Sub ФормаПоискаПоАктивномуСтолбцу(Optional Мультивыбор As Boolean, Optional Разделитель$ = "; ")
Dim x, arr1x(), dic As Object, cl As Range, r&, t!
t = Timer
Set cl = ActiveCell
r = Cells(Rows.Count, cl.Column).End(xlUp).Row
If r < 3 Then MsgBox "В столбце «" & cl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
Set dic = CreateObject("Scripting.Dictionary")
For Each x In Cells(2, cl.Column).Resize(r).Value
If Len(x) Then x = dic.Item(x)
Next x
If dic.Count = 0 Then MsgBox "В столбце «" & cl.Column & "» нет подходящих значений!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
arr1x = dic.Keys: dic.RemoveAll
If Not FS_Start(arr1x, Мультивыбор) Then Exit Sub
If UBound(arr1x) = 0 Then
cl.Value2 = arr1x(0)
Else
cl.Value2 = Join(arr1x, Разделитель)
End If
End Sub
'===========================================================================================
Private Function FS_Start(tmpArr(), Optional Multy As Boolean) As Boolean
FS_Sort tmpArr, 0, UBound(tmpArr)
FS_arr = tmpArr
Erase tmpArr
If Multy Then
FormSearch_Multy.Show
Else
FormSearch_Single.Show
End If
If Not IsArray(FS_arr) Then Exit Function
tmpArr = FS_arr
Erase FS_arr
FS_Start = True
End Function
'===========================================================================================
Private Sub FS_Sort(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FS_Sort arr1x, l, j
If i < u Then FS_Sort arr1x, i, u
End Sub
'===========================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Одна форма с возможностью единичного или множественного выделения (контроль при вызове, как и в предыдущей версии): • вызов формы такой же, как в предыдущей версии • выбрать множественные позиции теперь можно и кнопкой, и Enter'ом, а единичные (при обоих типах форм) — ещё и даблкликом • Enter в окне ввода перекидывает в список, то есть вызвав форму (с мультивыбором) и нажав 2 раза, можно сразу получить список всего отфильтрованного
Модуль книги
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim x, arr1x(), cl As Range, bT As Byte
Static delim$: If Len(delim) = 0 Or delim = "False" Then delim = " | "
Cancel = True: Set cl = ActiveCell: Set x = cl
If Not ПолучитьДанныеАктивногоСтолбца(x) Then Exit Sub Else arr1x = x
' выбираем тип формы для выбора значений (одно или несколько)
bT = MsgBox("Вызвать форму для ОДИНОЧНОГО выбора…?" & vbLf & vbLf & Space$(5) & "• [ДА] — для ОДИНОЧНОГО выбора" & vbLf & Space$(5) & "• [НЕТ] — для МНОЖЕСТВЕННОГО выбора", vbYesNoCancel + vbQuestion + vbDefaultButton1)
' получаем массив выбранных значений
If bT = vbYes Then
If Not FS_Start(arr1x) Then Exit Sub
ElseIf bT = vbNo Then
If Not FS_Start(arr1x, True) Then Exit Sub
Else
Exit Sub
End If
' выбираем, что делать с найденным (вставить сцепку или фильтровать на листе)
bT = MsgBox("Вставить найденные данные?" & vbLf & vbLf & Space$(5) & "• [ДА] — ВСТАВИТЬ" & vbLf & Space$(5) & "• [НЕТ] — ФИЛЬТРОВАТЬ на листе", vbYesNoCancel + vbQuestion + vbDefaultButton1)
' делаем то, что нужно
If bT = vbYes Then
If UBound(arr1x) = 0 Then cl.Value2 = arr1x(0): Exit Sub
If Not ВводРазделителя(delim) Then Exit Sub
cl.Value2 = Join(arr1x, delim)
ElseIf bT = vbNo Then
ActiveSheet.UsedRange.AutoFilter Field:=cl.Column, Criteria1:=arr1x, Operator:=xlFilterValues
Else
Exit Sub
End If
End Sub
'===========================================================================================
'===========================================================================================
Private Function ПолучитьДанныеАктивногоСтолбца(tmpCl) As Boolean
Dim x, dic As Object, r&, c&
c = tmpCl.Column
r = ActiveSheet.Cells(Rows.Count, tmpCl.Column).End(xlUp).Row 'определяем последнюю строку методом "прыжка" снизу
If r < 3 Then MsgBox "В столбце «" & c & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Function
' цикл по массиву всех значений столбца (от 2 строки до последней)
Set dic = CreateObject("Scripting.Dictionary")
For Each x In ActiveSheet.Cells(2, c).Resize(r).Value
If Len(x) Then x = dic.Item(x)
Next x
' проверка на наличие допустимых значений
If dic.Count = 0 Then MsgBox "В столбце «" & c & "» нет подходящих значений!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Function
tmpCl = dic.Keys: ПолучитьДанныеАктивногоСтолбца = True
End Function
'===========================================================================================
Private Function ВводРазделителя(delim$) As Boolean
inp: delim = Application.InputBox("Введите разделитель:", "Получение данных", CStr(delim), Type:=2)
If delim = "False" Then Exit Function
If Len(delim) = 0 Then MsgBox "Вы не ввели разделитель!", vbCritical, "ОШИБКА ВВОДА": GoTo inp
ВводРазделителя = True
End Function
Модуль
Код
Option Explicit
Option Private Module
Public FS_arr, FS_Mask$
'===========================================================================================
Function FS_Start(tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean
If Not DontSort Then FS_Sort tmpArr1x, 0, UBound(tmpArr1x)
FS_arr = tmpArr1x: Erase tmpArr1x
If Multy Then FormSearch.lb.MultiSelect = fmMultiSelectExtended
FormSearch.Show
If Not IsArray(FS_arr) Then Exit Function
tmpArr1x = FS_arr: Erase FS_arr
FS_Start = True
End Function
'-------------------------------------------------------------------------------------------
Private Sub FS_Sort(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FS_Sort arr1x, l, j
If i < u Then FS_Sort arr1x, i, u
End Sub
Форма
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
Me.bC.Visible = False
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out:
Me.tb_count.Value = Me.lb.ListCount
Me.tb_mask.SetFocus
If Me.lb.ListCount > 0 Then Me.bC.Visible = True
End Sub
'===========================================================================================
'===========================================================================================
Private Sub bC_Click()
Dim arr(), x, i&, n&
ReDim arr(UBound(arrFull))
For i = 0 To Me.lb.ListCount - 1
If Me.lb.Selected(i) Then arr(n) = Me.lb.List(i): n = n + 1
Next i
If n = 0 Then
If Me.lb.MultiSelect = fmMultiSelectSingle Then MsgBox "При вызове формы для одиночного выделения нельзя сформировать список из всего отфильтрованного!", vbExclamation, "ПУСТО": Exit Sub
If MsgBox("Ничего не выбрано…" & vbLf & "Сформировать список из ВСЕГО ОТФИЛЬТРОВАННОГО" & vbLf & "(" & Me.lb.ListCount & " элементов)?", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
ReDim arr(0 To UBound(arrFull)): n = 0
For Each x In Me.lb.List
arr(n) = x: n = n + 1
Next x
End If
fin: ReDim Preserve arr(n - 1): FS_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.ListIndex)
Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 38 Or KeyCode = 40 Then lb.SetFocus
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
If Me.lb.ListCount = 0 Then MsgBox "Список пуст!", vbExclamation, "ПУСТО": Exit Sub
bC_Click
End If
If KeyAscii = 27 Then Unload Me
End Sub
как можно увидеть, форма очень универсальна и, чтобы передать в неё данные, достаточно сформировать из них одномерный массив, заменив процедуру GetColumnData на другую (или передать иным способом). Диапазон применения такой формы очень обширен — достаточно вспомнить, как часто нам приходится выбирать что-то из списка, особенно, если список составляет больше десятка позиций. Для разных задач можно видоизменять форму в угоду узкой специализации — здесь же я постарался показать её возможности на интересном примере из последнего обновления PLEX. Старался не свалить всё в кучу, но и рассмотреть оба варианта - для одинарного и множественного выбора.
Замечания и предложения, как всегда, приветствуются
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Enter в окне ввода перекидывает в список, то есть вызвав форму (с мультивыбором) и нажав 2 раза, можно сразу получить список всего отфильтрованного
Уважаемый, Jack Famous. Ну не фильтрует по выбранному в столбце "А", а вставляет все выбранное в активную строку в столбце "А". Ни по нажатию на кнопку "ГОТОВО", ни по ENTER... Если я правильно понимаю написанное пояснение, то должно быть так: вызвал форму, в поле ввода ввел текст, макрос отработал, отсортировав искомое, я поставил галочки в позициях которые меня интересуют, нажал ENTER и на вкладке со списком макрос должен отфильтровать по столбцу "А" выбранные позиции, остальные скрыть, а он просто выбранные позиции вставляет в одну строку по очереди. Или что-то я делаю не так? Поясните, пожалуйста, очень нужна Ваша форма.
voxik-24: Ну не фильтрует по выбранному в столбце "А", а вставляет все выбранное в активную строку
всё верно. Отфильтрованные — это в списке формы, а не на листе Смотрите #19 - добавил возможность фильтрации данных на листе, но это уход от темы (исключение - в качестве примера демонстрации универсальности…)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Уважаемый, Jack Famous, все фильтрует, просто супер, но... в окне формы (скрин) последняя строка не влазит в пределы видимости. И еще вопрос: как я понял макрос не работает в "умных" таблицах?
voxik-24 написал: последняя строка не влазит в пределы видимости
Это проблема самого ListBox. Можно решить добавлением пустой строки в конце. Но это усложняет обработку, при выводе или просмотре данных нужно это учитывать.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
v 1.1 ================================================== Пример фильтрации текущего столбца с помощью данной формы
Модуль книги (пример вызова)
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim x, arr1x(), rng As Range, col As Byte
Cancel = True: Set x = ActiveCell: col = x.Column
If Not FS_GetActiveColumnData(x) Then Exit Sub ' получаем уникальные данные столбца и диапазон для фильтрации
arr1x = x(0): Set rng = x(1): Erase x
If Not FS_Start(arr1x, True) Then Exit Sub ' получаем массив выбранных значений
FS_Array1xForFilter arr1x ' преобразуем данные в массиве в текстовые (для корректной фильтрации)
If Not FS_Range_Filter(rng, col, arr1x, True) Then Exit Sub ' фильтруем диапазон
End Sub
Код формы (не изменился с #19)
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
Me.bC.Visible = False
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out:
Me.tb_count.Value = Me.lb.ListCount
Me.tb_mask.SetFocus
If Me.lb.ListCount > 0 Then Me.bC.Visible = True
End Sub
'===========================================================================================
'===========================================================================================
Private Sub bC_Click()
Dim arr(), x, i&, n&
ReDim arr(UBound(arrFull))
For i = 0 To Me.lb.ListCount - 1
If Me.lb.Selected(i) Then arr(n) = Me.lb.List(i): n = n + 1
Next i
If n = 0 Then
If Me.lb.MultiSelect = fmMultiSelectSingle Then MsgBox "При вызове формы для одиночного выделения нельзя сформировать список из всего отфильтрованного!", vbExclamation, "ПУСТО": Exit Sub
If MsgBox("Ничего не выбрано…" & vbLf & "Сформировать список из ВСЕГО ОТФИЛЬТРОВАННОГО" & vbLf & "(" & Me.lb.ListCount & " элементов)?", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
ReDim arr(0 To UBound(arrFull)): n = 0
For Each x In Me.lb.List
arr(n) = x: n = n + 1
Next x
End If
fin: ReDim Preserve arr(n - 1): FS_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.ListIndex)
Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 38 Or KeyCode = 40 Then lb.SetFocus
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
If Me.lb.ListCount = 0 Then MsgBox "Список пуст!", vbExclamation, "ПУСТО": Exit Sub
bC_Click
End If
If KeyAscii = 27 Then Unload Me
End Sub
Модуль отдельный (нафарширован)
Код
Option Explicit
Option Private Module
'===========================================================================================
Public FS_arr, FS_Mask$
'===========================================================================================
Function FS_Start(tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean
If Not DontSort Then FS_Sort tmpArr1x, 0, UBound(tmpArr1x)
FS_arr = tmpArr1x: Erase tmpArr1x
If Multy Then FormSearch.lb.MultiSelect = fmMultiSelectExtended
FormSearch.Show
If Not IsArray(FS_arr) Then Exit Function
tmpArr1x = FS_arr: Erase FS_arr
FS_Start = True
End Function
'===========================================================================================
Sub FS_Sort(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FS_Sort arr1x, l, j
If i < u Then FS_Sort arr1x, i, u
End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Function FS_GetActiveColumnData(tmpCl) As Boolean
Dim x, dic As New Dictionary, tbl As ListObject, rng As Range, lr&
On Error Resume Next
Set tbl = ActiveSheet.ListObjects(1) ' задаём умную таблицу (не более одной на листе)
On Error GoTo 0
' проверки
If tbl Is Nothing Then ' умной таблицы на листе нет
Set rng = ActiveSheet.UsedRange ' область = используемая область листа
lr = Cells(Rows.Count, tmpCl.Column).End(xlUp).Row ' определяем последнюю строку методом "прыжка" снизу по активному столбцу
If tmpCl.Row > lr Then Exit Function ' если активная строка ниже последней, то выходим
Else ' умная таблица присутствует на листе
Set rng = tbl.Range ' область = умная таблица
If Intersect(tmpCl, rng) Is Nothing Then Exit Function ' если не попали в область, то выходим
lr = tbl.ListRows.Count + 1 ' определяем последнюю строку, не учитывая строку итогов, если она есть
End If
If rng.Cells(1, 1).Row <> 1 Or rng.Cells(1, 1).Column <> 1 Then MsgBox "Область данных должна начинаться с ПЕРВОЙ ячейки листа!", vbExclamation, "ОШИБКА РАСПОЛОЖЕНИЯ ДАННЫХ": Exit Function
If lr < 3 Then MsgBox "В столбце «" & tmpCl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Function
' собираем массив уникальных данных из активного столбца
For Each x In Cells(2, tmpCl.Column).Resize(lr - 1).Value2
x = dic.Item(x)
Next x
' финиш
ReDim tmpCl(1) ' возвращаем массив из 2ух объектов:
tmpCl(0) = dic.Keys ' одномерный массив уникальных элементов для формы
Set tmpCl(1) = rng ' фильтруемый диапазон
FS_GetActiveColumnData = True
End Function
'===========================================================================================
Sub FS_Array1xForFilter(arr())
Dim i&
For i = 0 To UBound(arr)
If IsNumeric(arr(i)) Then
arr(i) = CStr(arr(i))
End If
Next i
End Sub
'===========================================================================================
Function FS_Range_Filter(rng As Range, col As Byte, arrFilter, Optional MsgIfFalse As Boolean) As Boolean
On Error GoTo er
rng.Parent.AutoFilterMode = False
rng.AutoFilter Field:=col, Criteria1:=arrFilter, Operator:=xlFilterValues
FS_Range_Filter = True: Exit Function
er: Err.Clear: If MsgIfFalse Then MsgBox "Диапазон не отфильтрован!", vbCritical, "FS_Range_Filter"
End Function
'Criteria1:=Array("0,525635481", "0,844466686", "1,254856586"), Operator:=xlFilterValues ' DOUBLE (не более 10 знаков без запятой)
'Operator:=xlFilterValues, Criteria2:=Array(2, "1/9/2017", 2, "1/26/2017") ' DATE
'Criteria1:=Array("0:23:15", "0:23:55", "0:29:46"), Operator:=xlFilterValues ' TIME
БАЗА • 2 основных макроса: функция FS_Start и процедура FS_Sort
ЧТО ПЕРЕДАТЬ В ФУНКЦИЮ • в функцию нужно передать одномерный массив (LBound=0). Как вы его получите - не важно (далее есть пример) • можно выбрать, сортировать (по-умолчанию) или нет массив перед передачей в форму • для сортировки используется рекурсивная процедураFS_Sortотсюда (как по мне — лучшее сочетание скорости и универсальности)
ТИП ФОРМЫ • можно выбрать только одного значение • можно выбрать одно и более значений (по-умолчанию)
ПОИСК В ФОРМЕ • поиск осуществляется по маске, но из служебных символов доступна только "звёздочка" «*» • при поиске видимая в окне маска ввода отличается от реальной: в реальной заменены служебные символы "[]?#", кроме "*", а также присутствует хвостовая "*" справа (маска = маска & "*") • наличие ведущей "*" спереди контролируется кнопкой "по всей строке/с начала строки" • при запуске формы фокус будет на поле ввода маски, а в качестве маски будет использована последняя введённая (запоминается) • при нажатии клавиш "Ввод" и "Стрелка вниз/вверх" фокус сместится на список
ВЫБОР ЗНАЧЕНИЙ • перемещение по списку осуществляется с помощью клавиш "Стрелка вниз/вверх" или мышью (полосы прокрутки слева и снизу) • если строки слишком длинные, сдвигайте полосу прокрутки снизу, чтобы просмотреть всю строку • выбор осуществляется нажатием кнопки ГОТОВО - на форме, Ввод - на клавиатуре или даблклик - в списке (последнее - только, если выбран один элемент) • выйти из формы можно по крестику на форме или нажав Esc на клавиатуре (на любом этапе) • таким образом, всю работу с формой можно осуществлять без помощи мыши
ЧТО ВЕРНЁТ ФУНКЦИЯ • False — если в ней ничего не было выбрано • True — если в ней было выбрано хоть одно значение, а также изменит переданный ей массив, наполнив его только выбранными значениями
КАК ПЕРЕНЕСТИ В ДРУГОЙ ФАЙЛ • перенести из редактора 2 объекта: форму FormSearch и модуль FormSearch_macro • определиться с условиями вызова. Если нужно так, как в примере, то скопировать код из модуля книги примера в модуль книги своего файла
ИТОГО 1. передаём одномерный массив для поиска 2. ищем в нём 3. если что-то отметили, то получили назад одномерный массив с выбранным
ПРИМЕР • в примере осуществлён процесс поиска и фильтрации по активному столбцу Вставка рассмотрена в постах выше (ActiveCell.Value2 = Join(вернувшийся_массив_выбранных_значений,разделитель)) • срабатывает по даблклику в любом месте файла (событие книги), если соблюдены условия • работает в умных таблицах и на простых диапазонах • условия: 1. "попасть" в область данных 2. наличие "шапки" (заголовки полей/столбцов) 3. не менее 2 значений в столбце, кроме шапки (иначе какой смысл) • нюанс: для ускорения словарей используется раннее связывание (в файле-примере подключено). Если при переносе вы не уверены, сможете ли обеспечить раннее связывание на другом компьютере, то используйте позднее:
Код
Dim Dic As Object
Set Dic=CreateObject("Scripting.Dictionary")
• ограничение: не фильтрует десятичные числа более 10 знаков (без запятой, включая целую и дробную часть) и всё в "индивидуальных" форматах типа числового ("общий" фильтрует), денежного, даты, времени и т.д.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
v 1.2 ИЗМЕНЕНИЯ: • добавлена проверка на выполнение фильтрации (взял отсюда) • улучшен сброс фильтра (взял отсюда) • преобразование данных массива в текстовые теперь обязательное, без проверок и находится внутри функции фильтрации, а не в отдельной процедуре, т.к. выполняется очень быстро • вспомогательные макросы вынесены из основного модуля в отдельный (логика компоновки) Так как для работы формы нужна только форма и её модуль, то решил всё остальное вынести в отдельный модуль Example. Он на непосредственную работу формы не влияет и присутствует только для обеспечения примера (фильтровать активный столбец) • мелкие несущественные дополнения и улучшения
Код из формы «FormSearch»
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FS_arr: FS_arr = 0
If Len(FS_Mask) Then
Me.tb_mask.Value = FS_Mask
Else
ArrayFilterByMask
End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
FS_Mask = Me.tb_mask.Value
End Sub
'===========================================================================================
Private Sub tb_mask_Change()
ArrayFilterByMask
End Sub
'-------------------------------------------------------------------------------------------
Private Function MaskReplace() As String
Dim x, mask$
mask = Me.tb_mask.Value
For Each x In arrSym
If InStr(mask, x) Then mask = Replace(mask, x, "")
Next x
MaskReplace = UCase(mask)
End Function
'===========================================================================================
'===========================================================================================
Private Sub ArrayFilterByMask()
Dim arr(), x, mask$, n&
Me.bC.Visible = False
If Len(Me.tb_mask.Value) = 0 Then Me.lb.List = arrFull: GoTo out
If Me.bT.Value = True Then
mask = MaskReplace & "*"
Else
mask = "*" & MaskReplace & "*"
End If
Me.lb.Clear: ReDim arr(UBound(arrFull)): n = -1
For Each x In arrFull
If UCase(x) Like mask Then n = n + 1: arr(n) = x
Next x
If n > -1 Then ReDim Preserve arr(n): Me.lb.List = arr
out:
Me.tb_count.Value = Me.lb.ListCount
Me.tb_mask.SetFocus
If Me.lb.ListCount > 0 Then Me.bC.Visible = True
End Sub
'===========================================================================================
'===========================================================================================
Private Sub bC_Click()
Dim arr(), x, i&, n&
ReDim arr(UBound(arrFull))
For i = 0 To Me.lb.ListCount - 1
If Me.lb.Selected(i) Then arr(n) = Me.lb.List(i): n = n + 1
Next i
If n = 0 Then
If Me.lb.MultiSelect = fmMultiSelectSingle Then MsgBox "При вызове формы для одиночного выделения нельзя сформировать список из всего отфильтрованного!", vbExclamation, "ПУСТО": Exit Sub
If MsgBox("Ничего не выбрано…" & vbLf & "Сформировать список из ВСЕГО ОТФИЛЬТРОВАННОГО" & vbLf & "(" & Me.lb.ListCount & " элементов)?", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
ReDim arr(0 To UBound(arrFull)): n = 0
For Each x In Me.lb.List
arr(n) = x: n = n + 1
Next x
End If
fin: ReDim Preserve arr(n - 1): FS_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FS_arr(0)
FS_arr(0) = lb.List(lb.ListIndex)
Unload Me
End Sub
'===========================================================================================
Private Sub bT_Click()
If Me.bT.Value = True Then
Me.bT.Caption = "с начала строки": Me.bT.BackStyle = fmBackStyleTransparent
Else
Me.bT.Caption = "по всей строке": Me.bT.BackStyle = fmBackStyleOpaque
End If
ArrayFilterByMask
End Sub
'===========================================================================================
'===========================================================================================
'===========================================================================================
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub chb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_mask_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 38 Or KeyCode = 40 Then lb.SetFocus
End Sub
'-------------------------------------------------------------------------------------------
Private Sub tb_count_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then Unload Me
End Sub
'===========================================================================================
Private Sub lb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
If Me.lb.ListCount = 0 Then MsgBox "Список пуст!", vbExclamation, "ПУСТО": Exit Sub
bC_Click
End If
If KeyAscii = 27 Then Unload Me
End Sub
Модуль «FormSearch_macro»
Код
Option Explicit
Option Private Module
'===========================================================================================
Public FS_arr, FS_Mask$
'===========================================================================================
Function FS_Start(tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean
If Not DontSort Then FS_Sort tmpArr1x, 0, UBound(tmpArr1x)
FS_arr = tmpArr1x: Erase tmpArr1x
If Multy Then FormSearch.lb.MultiSelect = fmMultiSelectExtended
FormSearch.Show
If Not IsArray(FS_arr) Then Exit Function
tmpArr1x = FS_arr: Erase FS_arr
FS_Start = True
End Function
'===========================================================================================
Sub FS_Sort(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FS_Sort arr1x, l, j
If i < u Then FS_Sort arr1x, i, u
End Sub
Модуль «Example»
Код
Option Explicit
'===========================================================================================
Function FILE_Range_Filter(rng As Range, col As Byte, arrFilter, Optional MsgIfFalse As Boolean) As Boolean
Dim sh As Worksheet, tbl As ListObject, i&
Set sh = rng.Parent
For i = 0 To UBound(arrFilter) ' преобразуем элементы входного массива в текстовые
arrFilter(i) = CStr(arrFilter(i))
Next i
On Error Resume Next: sh.ShowAllData: Err.Clear ' сбрасываем фильтр
rng.AutoFilter Field:=col, Criteria1:=arrFilter, Operator:=xlFilterValues ' фильтруем
If Err Then GoTo er Else On Error GoTo 0 ' если ошибка, значит фильтр сработал некорректно
i = sh.AutoFilter.Range.Columns(1).SpecialCells(xlVisible).Count - 1 ' считаем видимые строки после фильтрации (минус строка шапки)
If i = 0 Then GoTo er ' если видимых строк нет, значит фильтр сработал некорректно
If i = 1 Then ' если видимая строка одна, то это может быть строка итогов "умной" таблицы. Проверяем…
On Error Resume Next: Set tbl = sh.ListObjects(1): On Error GoTo 0 ' задаём умную таблицу (не более одной на листе)
If Not tbl Is Nothing Then ' если таблица есть, то проверяем дальше. В противном случае: нет таблиц —> нет итогов —> одна отфильтрованная строка
If tbl.ShowTotals Then GoTo er ' если итоги есть, то именно они и видны, а значит фильтр сработал некорректно
End If
End If
FILE_Range_Filter = True: Exit Function ' если дошли досюда, то всё ОК
er:
sh.ShowAllData ' сбрасываем фильтр
rng.AutoFilter ' убираем кнопочки (если они стоят, то я думаю, что автофильтр включён)
If MsgIfFalse Then MsgBox "Диапазон не отфильтрован!", vbCritical, "FILE_Range_Filter" ' если по ошибке нужно было вывести сообщение (параметр функции), то выводим
End Function
'Criteria1:=Array("0,525635481", "0,844466686", "1,254856586"), Operator:=xlFilterValues ' DOUBLE (не более 10 знаков без запятой)
'Operator:=xlFilterValues, Criteria2:=Array(2, "1/9/2017", 2, "1/26/2017") ' DATE
'Criteria1:=Array("0:23:15", "0:23:55", "0:29:46"), Operator:=xlFilterValues ' TIME
'===========================================================================================
Function FILE_Range_GetActiveColumnData(tmpCl) As Boolean
Dim x, dic As New Dictionary, sh As Worksheet, tbl As ListObject, rng As Range, lr&
Set sh = tmpCl.Parent
On Error Resume Next: Set tbl = sh.ListObjects(1): On Error GoTo 0
' проверки
If tbl Is Nothing Then ' умной таблицы на листе нет
Set rng = sh.UsedRange ' область = используемая область листа
lr = sh.Cells(Rows.Count, tmpCl.Column).End(xlUp).Row ' определяем последнюю строку методом "прыжка" снизу по активному столбцу
If tmpCl.Row > lr Then Exit Function ' если активная строка ниже последней, то выходим
Else ' умная таблица присутствует на листе
Set rng = tbl.Range ' область = умная таблица
If Intersect(tmpCl, rng) Is Nothing Then Exit Function ' если не попали в область, то выходим
lr = tbl.ListRows.Count + 1 ' определяем последнюю строку, не учитывая строку итогов, если она есть
End If
If rng.Cells(1, 1).Row <> 1 Or rng.Cells(1, 1).Column <> 1 Then MsgBox "Область данных должна начинаться с ПЕРВОЙ ячейки листа!", vbExclamation, "ОШИБКА РАСПОЛОЖЕНИЯ ДАННЫХ": Exit Function
If lr < 3 Then MsgBox "В столбце «" & tmpCl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Function
' собираем массив уникальных данных из активного столбца
For Each x In sh.Cells(2, tmpCl.Column).Resize(lr - 1).Value2
x = dic.Item(x)
Next x
' финиш
ReDim tmpCl(1) ' возвращаем массив из 2ух объектов:
tmpCl(0) = dic.Keys ' одномерный массив уникальных элементов для формы
Set tmpCl(1) = rng ' фильтруемый диапазон
FILE_Range_GetActiveColumnData = True
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, я попробовал сохранить файл с расширением .xlam и установить как надстройку (для исключения привязки к отдельным файлам), но желаемого результата не получил... как это сделать?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄