================================================== Изначально эта была тема об альтернативе инструменту "Выпадающий список с автопоиском" из , но после было решено обобщить тему до принципа работы формы (передача, поиск и возврат данных).
Спасибо всем, кто помогал и продолжает это делать на нашем любимом форуме! Отдельная благодарность за постоянные улучшения и объяснения Alemox Изменение, адаптация и усовершенствования формы под конкретные задачи - в личку
Инструменты, работающие на основе такой формы (начаты по ссылкам, но впоследствии объединены тут в ОДНУ надстройку):
Ссылки: из nerv_DropDownList ( + )
================================================== Выставляю на общий суд и для активного использования форму для поиска по активному столбцу. Форма очень шустрая.
ОБЩИЙ ПРИНЦИП ДЕЙСТВИЯ 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
'===========================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 25.02.2013
16.08.2019 19:16:43
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 - скопировано из базы данных
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Пользователь
Сообщений: Регистрация: 15.09.2012
16.08.2019 21:55:15
"Сформировать список из всего видимого?" - но на экране может быть видима только часть отфильтрованных строк.
это был баг, а не фича благодарю за отзыв, поправки и "допиленную" версию — если не все, то большинство точно приму в работу P.S.: расшифровка никнейма - бомба UPD: отловил ошибку при при растягивании формы (слишком сильно сужение; см. скрин). Поправлю не раньше завтра/послезавтра (не сталкивался, но, думаю, ничего сложного)…
это мой никнейм ващет)) как-то хотел и тут сменить, но сошлись (с вами или с Юрием) на том, что не стоит. В названии темы фигурирует, потому что это не просто моя тема, а вроде готового решения. По нему будет всегда просто их найти
. Да, слишком увлекаться не надо. Обычно ставлю ограничение. Тут просто как пример не стал. Добавить надо ограничение на минимальный размер UsrForm.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Jack Famous: В названии темы фигурирует, потому что это не просто моя тема, а вроде готового решения. По нему будет всегда просто их найти
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Модератор
Сообщений: Регистрация: 14.09.2012
Контакты см. в профиле
17.08.2019 22:42:39
Джек, другие пользователи будут искать по нику, который никому ничего не говорит или по задаче? Если Вы про свой поиск - добавьте тему в своё избранное. Удивляюсь, что нужно Вам это объяснять...
Пользователь
Сообщений: Регистрация: 22.05.2018
18.08.2019 00:04:34
Доброго времени суток. Макрос не плохой, работает быстро и только... Для чего он предназначен - не понятно. Вот если он фильтровал по выбору сразу данные на активном листе - вот тогда да, БОМБА!!! Как правило приходится изгаляться в больших таблицах это сделать. А так вставить отфильтрованное... это можно и простым копированием... И еще.... в Вашу таблицу вставил 50 000 строк с текстом, так вот макрос по двойному клику не работает на вставленных строках, а только на изначальных, хотя уже в окне макроса вставленные строки видны и поиск работает. Как вставить больше одной позиции так и не понял: ЛКМ не удалось выделить, через CTRL не работает....
Модератор
Сообщений: Регистрация: 28.12.2016
Excel 2013, 2016, 2021
18.08.2019 12:36:21
Jack Famous, Алексей, а почему не запросом SQL? В одном флаконе и фильтр и сортировка и уникальность в результирующем recordset.
Юрий М: другие пользователи будут искать по нику, который никому ничего не говорит или по задаче?
по нику мной создано немало тем, а тех, что с "готовым решением" пока только одна. Таким образом, указание моего основного никнейма, используемого в том числе при разработке, даёт очень важный тэг для поиска. Считаю это важным для порядка. Абсолютно не против, если вы перенесёте 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. Старался не свалить всё в кучу, но и рассмотреть оба варианта - для одинарного и множественного выбора.
Замечания и предложения, как всегда, приветствуются
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 22.05.2018
19.08.2019 12:41:52
Цитата
Jack Famous написал: Enter в окне ввода перекидывает в список, то есть вызвав форму (с мультивыбором) и нажав 2 раза, можно сразу получить список всего отфильтрованного
Уважаемый, Jack Famous. Ну не фильтрует по выбранному в столбце "А", а вставляет все выбранное в активную строку в столбце "А". Ни по нажатию на кнопку "ГОТОВО", ни по ENTER... Если я правильно понимаю написанное пояснение, то должно быть так: вызвал форму, в поле ввода ввел текст, макрос отработал, отсортировав искомое, я поставил галочки в позициях которые меня интересуют, нажал ENTER и на вкладке со списком макрос должен отфильтровать по столбцу "А" выбранные позиции, остальные скрыть, а он просто выбранные позиции вставляет в одну строку по очереди. Или что-то я делаю не так? Поясните, пожалуйста, очень нужна Ваша форма.
voxik-24: Ну не фильтрует по выбранному в столбце "А", а вставляет все выбранное в активную строку
всё верно. Отфильтрованные — это в списке формы, а не на листе Смотрите - добавил возможность фильтрации данных на листе, но это уход от темы (исключение - в качестве примера демонстрации универсальности…)
Изменено: - 19.08.2019 15:12:57
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 22.05.2018
19.08.2019 16:47:09
Уважаемый, 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
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 05.12.2016
21.08.2019 12:51:57
Jack Famous, я попробовал сохранить файл с расширением .xlam и установить как надстройку (для исключения привязки к отдельным файлам), но желаемого результата не получил... как это сделать?
