v 1.3 ИЗМЕНЕНИЯ: • добавлены префиксы к публичным переменным ("FFF_") и процедурам ("FILE_") формы. Нужно для того, чтобы их быстро можно было заменить на другие в случае конфликта имён. Например, у меня надстройка с такой же формой и в ней всё аналогичное, кроме префиксов. • оставлены только модуль формы и стандартный модуль. Оформлено всё в надстройку Работа с надстройкой только через функцию: FILE_Search_Start (tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean
Код из формы «FormSearch»
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FFF_Search_arr: FFF_Search_arr = 0
If Len(FFF_Search_Mask) Then
Me.tb_mask.Value = FFF_Search_Mask
Else
ArrayFilterByMask
End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
FFF_Search_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): FFF_Search_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FFF_Search_arr(0)
FFF_Search_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 FFF_Search_arr, FFF_Search_Mask$
'===========================================================================================
Function FILE_Search_Start(tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean
If Not DontSort Then FILE_Search_Sort tmpArr1x, 0, UBound(tmpArr1x)
FFF_Search_arr = tmpArr1x: Erase tmpArr1x
If Multy Then FILE_Search.lb.MultiSelect = fmMultiSelectExtended
FILE_Search.Show
If Not IsArray(FFF_Search_arr) Then Exit Function
tmpArr1x = FFF_Search_arr: Erase FFF_Search_arr
FILE_Search_Start = True
End Function
'===========================================================================================
Sub FILE_Search_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 FILE_Search_Sort arr1x, l, j
If i < u Then FILE_Search_Sort arr1x, i, u
End Sub
Пример с фильтрацией по активному столбцу теперь развивается в
azma, как обычную надстройку. Есть статья в Приёмах
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 05.12.2016
25.08.2019 14:20:19
Jack Famous, доброе время суток. После установки надстройки, в редакторе VBA схватил мышкой проект надстройки и перетащил его на проект целевого файла. Вкладка референсес появилась. Перешел на лист целевого файла (со списком). Двойной жмяк на любой ячейке столбца с интересующим списком не дает никакого эффекта, кроме обычного проваливания в ячейку... Сохранил файл, закрыл его, снова открыл - ничего не изменилось - двойной жмяк по ячейке приводит к проваливанию в ячейку. Зашел в редактор VBA - вкладка референсес исчезла.
Подозреваю, что причина в том, что не выполнено это условие: "Работа с надстройкой только через функцию: FILE_Search_Start (tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean"
Что нужно сделать, что-бы работа с надстройкой была через эту функцию?
Jack Famous (из #31): Пример с фильтрацией по активному столбцу теперь развивается в отдельной теме
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 05.12.2016
26.08.2019 14:02:23
Jack Famous, а меня как раз интересует именно поиск значений в столбце по любой части строки, для последующего выбора наиболее подходящего и вставки его в этот-же столбец... т.е. фильтрация в данном контексте не нужна.
Снова объединил последние версии для фильтрации и вставки в 1 модуль/макрос Вызов отличается одним необязательным булевым параметром (для вставки)
Вызов по событию книги (даблклик)
Код
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("Хотите отфильтровать столбец [ДА] или просто вставить выбранные значения [НЕТ]?", vbYesNoCancel + vbInformation + vbDefaultButton1, "Выбор действия")
If bt = vbCancel Then Exit Sub
If bt = vbYes Then FRM_Search_ActiveColumn.Start Else FRM_Search_ActiveColumn.Start True
End Sub
Модуль фильтра/вставки «FRM_Search_ActiveColumn»
Код
Option Explicit
Const delim$ = " " ' Chr(32) & Chr(26) & Chr(32)
'===========================================================================================
Sub Start(Optional Insert As Boolean)
Dim sh As Worksheet, rng As Range, rngCol As Range, cl As Range
Dim x, arr, arr1x(), NF$, lr&, i&
' получаем уникальные данные столбца и диапазон для фильтрации
Set sh = ActiveWorkbook.ActiveSheet: Set cl = ActiveCell
On Error Resume Next: Set x = sh.ListObjects(1): On Error GoTo 0
If TypeName(x) <> "ListObject" Then
Set rng = sh.UsedRange
lr = sh.Cells(Rows.Count, cl.Column).End(xlUp).Row
If cl.Row > lr Then Exit Sub
Else
Set rng = x.Range
If Intersect(cl, rng) Is Nothing Then Exit Sub
lr = x.ListRows.Count + 1
End If
If rng.Cells(1, 1).Row <> 1 Or rng.Cells(1, 1).Column <> 1 Then MsgBox "Область данных должна начинаться с ПЕРВОЙ ячейки листа!", vbExclamation, "ОШИБКА РАСПОЛОЖЕНИЯ ДАННЫХ": Exit Sub
If lr < 3 Then MsgBox "В столбце «" & cl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
' получаем столбец и его данные, получаем список найденного по форме
Set rngCol = sh.Cells(2, cl.Column).Resize(lr - 1).SpecialCells(xlVisible)
NF = cl.NumberFormat: x = NumberFormat_Replace(cl)
arr1x = RangeToArray1x(rngCol, x)
If Not FRM_Search_Start(arr1x, True) Then Exit Sub
If Len(x) Then ' если нужно было учитывать формат, то берём из каждого элемента левую часть до разделителя и преобразуем в текстовый
For i = 0 To UBound(arr1x)
arr1x(i) = CStr(Left$(arr1x(i), InStr(arr1x(i), delim) - 1))
Next i
Else ' если разделителя нет, то просто преобразуем в текстовый
For i = 0 To UBound(arr1x)
arr1x(i) = CStr(arr1x(i))
Next i
End If
' если нужно просто вставить, то вставляем и выходим
If Insert Then
If UBound(arr1x) = 0 Then
If IsNumeric(arr1x(0)) Then ActiveCell.Value2 = --arr1x(0) Else ActiveCell.Value2 = arr1x(0)
Else
ActiveCell.Value2 = Join(arr1x, "; ")
End If
Exit Sub
End If
' преобразуем
Application.ScreenUpdating = False
rngCol.NumberFormat = "@"
On Error Resume Next
rng.AutoFilter Field:=cl.Column, Criteria1:=arr1x, Operator:=xlFilterValues
If Err Then GoTo erFilt Else Err.Clear
i = rngCol.SpecialCells(xlVisible).Count
If Err Or i = 0 Then GoTo erFilt Else On Error GoTo 0
NumberFormat_Return rngCol, NF
GoTo fin
erFilt:
MsgBox "Диапазон не отфильтрован!", vbCritical, "ОШИБКА ФИЛЬТРАЦИИ"
NumberFormat_Return rngCol, NF
fin: Application.ScreenUpdating = True
End Sub
'===========================================================================================
Private Function NumberFormat_Replace(cl As Range) As String
Dim NumFormat$: NumFormat = cl.NumberFormat
If NumFormat = "General" Or NumFormat = "@" Then Exit Function
If IsDate(cl) Then
If NumFormat Like "*h*" Then NumberFormat_Replace = "yyyy.mm.dd hh-mm-ss" Else NumberFormat_Replace = "yyyy-mm-dd"
Exit Function
End If
If NumFormat Like "*h*:*" Then NumberFormat_Replace = "[h]:mm:ss": Exit Function
If NumFormat Like "*0*.*0*" Then NumberFormat_Replace = "# ##0.00": Exit Function
End Function
'===========================================================================================
Private Function RangeToArray1x(ByVal rng As Range, ByVal NumFormat$) As Variant()
Dim dic As New Dictionary, ar As Range
Dim x, arr, i&
If Len(NumFormat) Then
For Each ar In rng.Areas
If ar.Count = 1 Then
x = ar.Value2 & delim & WorksheetFunction.Text(ar.Value2, NumFormat)
x = dic.Item(x)
Else
arr = ar.Value2
For Each x In arr
x = x & delim & WorksheetFunction.Text(x, NumFormat)
x = dic.Item(x)
Next x
End If
Next ar
Else
For Each ar In rng.Areas
If ar.Count = 1 Then
x = dic.Item(ar.Value2)
Else
arr = ar.Value2
For Each x In arr
x = dic.Item(x)
Next x
End If
Next ar
End If
RangeToArray1x = dic.Keys
End Function
'===========================================================================================
Private Sub NumberFormat_Return(rng As Range, ByVal NumFormat$)
Dim cl As Range
rng.NumberFormat = NumFormat
For Each cl In rng
If cl.EntireRow.Hidden Then cl.NumberFormat = NumFormat
Next cl
End Sub
Модуль для формы
Код
Option Explicit
Option Private Module
'===========================================================================================
Public FRM_Search_arr, FRM_Search_Mask$
'===========================================================================================
Function FRM_Search_Start(tmpArr1x(), Optional Multy As Boolean, Optional DontSort As Boolean) As Boolean
If Not DontSort Then FRM_Search_Sort tmpArr1x, 0, UBound(tmpArr1x)
FRM_Search_arr = tmpArr1x: Erase tmpArr1x
If Multy Then FRM_Search.lb.MultiSelect = fmMultiSelectExtended
FRM_Search.Show
If Not IsArray(FRM_Search_arr) Then Exit Function
tmpArr1x = FRM_Search_arr: Erase FRM_Search_arr
FRM_Search_Start = True
End Function
'===========================================================================================
Sub FRM_Search_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 FRM_Search_Sort arr1x, l, j
If i < u Then FRM_Search_Sort arr1x, i, u
End Sub
Код формы
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = FRM_Search_arr: FRM_Search_arr = 0
If Len(FRM_Search_Mask) Then
Me.tb_mask.Value = FRM_Search_Mask
Else
ArrayFilterByMask
End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
FRM_Search_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): FRM_Search_arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim FRM_Search_arr(0)
FRM_Search_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
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 05.12.2016
26.08.2019 16:50:22
Jack Famous, спасибо большое за труды но я так и не смог запустить эту надстройку:( запуск макроса старт вызывает стандартное окно с макросами, в котором нет никаких макросов для выбора для использования надстройки в разных файлах нужно в каждом делать перетаскивание проекта надстройки на проект целевого файла?
DNC: для использования надстройки в разных файлах нужно в каждом делать перетаскивание проекта надстройки на проект целевого файла?
таким образом, вы делаете макросы из надстройки видимыми в книге. Отсюда и ответ: запускаете макрос из книги - да, нужна ссылка, а если у вас макрос выведен кнопкой на панель, то нет Ну и, разумеется, на любой чих можно и команды написать (ссылки давал) Я "фарширую" файл формой и модулями, то есть без использования надстройки. Но в моей личной надстройке такая форма есть (для использования внутри неё). Таким образом, у меня и ссылок-то не надо
Изменено: - 26.08.2019 17:30:23
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
v 1.5 • снова изменены имена публичных переменных, функций и процедур • в надстройке подключены библиотеки для обеспечения раннего связывания • фильтр сработает только если вызов произошёл внутри области данных листа, а вот вставка сработает и вне неё • при выборе нескольких значений для сцепки, будет запрошен разделитель, который запоминается • тип вызванной процедуры (фильтр или вставка) отображается в шапке формы • всё улучшено и допилено • добавлены "горячие клавиши" для вызова процедур из любого файла: — для фильтрации: вызов процедуры ADD_FRM_Search_ActiveColumn.StartFilter по Ctrl+Shift+X — для вставки: вызов процедуры ADD_FRM_Search_ActiveColumn.StartInsert по Ctrl+Shift+Z i на скрине показано, как вывести 2 кнопки (для вызова фильтрации или вставки) на панель быстрого доступа i иногда надстройка (не только моя) не хочет автозапускаться (даже будучи подключенной) вместе с приложением Excel и запускается (становится видна в VBE) только при запуске любой процедуры из неё. Чтобы гарантировано синхронизировать запуски советую создать ярлык надстройки и положить его в папку
Модуль книги надстройки с закомментированным примером вызова процедур по событию книги (только этот закомментированный код нужно будет скопировать в модуль книги нужного ФАЙЛА, а не надстройки)
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_Open()
Application.OnKey "^+{X}", "ADD_FRM_Search_ActiveColumn.StartFilter"
Application.OnKey "^+{Z}", "ADD_FRM_Search_ActiveColumn.StartInsert"
End Sub
'===========================================================================================
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "^+{X}"
Application.OnKey "^+{Z}"
End Sub
'===========================================================================================
' пример вызова процедур по событию — даблклик
'Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'ADD_FRM_Search_ActiveColumn.StartFilter
'ADD_FRM_Search_ActiveColumn.StartInsert
'End Sub
Код формы «ADD_FRM_Search»
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = AAA_FRM_Search_Arr: AAA_FRM_Search_Arr = 0
If Len(AAA_FRM_Search_Mask) Then
Me.tb_mask.Value = AAA_FRM_Search_Mask
Else
ArrayFilterByMask
End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
AAA_FRM_Search_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): AAA_FRM_Search_Arr = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim AAA_FRM_Search_Arr(0)
AAA_FRM_Search_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
Модуль взаимодействия с активным столбцом «ADD_FRM_Search_ActiveColumn»
Код
Option Explicit
Const delSearch$ = " " ' Chr(32) & Chr(26) & Chr(32)
'===========================================================================================
Sub StartFilter()
Start
End Sub
'===========================================================================================
Sub StartInsert()
Start True
End Sub
'===========================================================================================
'===========================================================================================
Private Sub Start(Optional Insert As Boolean)
Dim Sh As Worksheet, rng As Range, rngCol As Range, cl As Range
Dim x, arr, arr1x(), NF$, NFr$, lr&, i&, flagOut As Boolean
Static delInsert$: If Len(delInsert) = 0 Then delInsert = "; "
' получаем уникальные данные столбца и диапазон для фильтрации
Set Sh = ActiveWorkbook.ActiveSheet: Set cl = ActiveCell
On Error Resume Next: Set x = Sh.ListObjects(1): On Error GoTo 0
If TypeName(x) <> "ListObject" Then
Set rng = Sh.UsedRange
lr = Sh.Cells(Rows.count, cl.Column).End(xlUp).Row
If cl.Row > lr Then flagOut = True
Else
Set rng = x.Range
If Intersect(cl, rng) Is Nothing Then flagOut = True
lr = x.ListRows.count + 1
End If
If rng.Cells(1, 1).Row <> 1 Or rng.Cells(1, 1).Column <> 1 Then MsgBox "Область данных должна начинаться с ПЕРВОЙ ячейки листа!", vbExclamation, "ОШИБКА РАСПОЛОЖЕНИЯ ДАННЫХ": Exit Sub
If lr < 3 Then MsgBox "В столбце «" & cl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
Set rngCol = Sh.Cells(2, cl.Column).Resize(lr - 1).SpecialCells(xlVisible)
NF = cl.NumberFormat
NFr = NumberFormat_Replace(NF)
arr1x = RangeToArray1x(rngCol, NFr)
If Insert Then
If Not ADD_FRM_Search_macro.Start(arr1x, True, "Форма для ПОИСКА значений и ВСТАВКИ в активную ЯЧЕЙКУ") Then Exit Sub
Else
If flagOut Then Exit Sub
If Not ADD_FRM_Search_macro.Start(arr1x, True, "Форма для ПОИСКА значений и ФИЛЬТРА активного СТОЛБЦА") Then Exit Sub
End If
' вставляем
If Insert Then
If UBound(arr1x) > 0 Then ' если выбрано более 1 значения…
If Not InsertDelim(delInsert) Then Exit Sub ' выбираем разделитель для вставки нескольких значений
If Len(NFr) Then ' если был разделитель в списке поиска, то берём из каждого элемента ПРАВУЮ (отформатированную) часть после разделителя
For i = 0 To UBound(arr1x)
arr1x(i) = Mid$(arr1x(i), InStr(arr1x(i), delSearch) + Len(delSearch))
Next i
End If
cl.Value2 = Join(arr1x, delInsert): Exit Sub ' вставляем текстовую сцепку и выходим
End If
x = arr1x(0): If Len(NFr) Then x = Left$(x, InStr(x, delSearch) - 1) ' если был разделитель в списке поиска, то берём только ЛЕВУЮ (значение без форматов) часть до разделителя
If IsNumeric(x) Then cl.Value2 = --x Else cl.Value2 = x ' если значение числовое, то вставляем числом, иначе — как есть
Exit Sub ' выходим
End If
' фильтруем
If Len(NFr) Then ' если был разделитель в списке поиска, то берём из каждого элемента ЛЕВУЮ (значение без форматов) часть до разделителя и преобразуем в текстовый
For i = 0 To UBound(arr1x)
arr1x(i) = CStr(Left$(arr1x(i), InStr(arr1x(i), delSearch) - 1))
Next i
Else ' если разделителя нет, то просто преобразуем в текстовый
For i = 0 To UBound(arr1x)
arr1x(i) = CStr(arr1x(i))
Next i
End If
Application.ScreenUpdating = False
If Len(NFr) Then rngCol.NumberFormat = "@"
On Error Resume Next
rng.AutoFilter field:=cl.Column, Criteria1:=arr1x, Operator:=xlFilterValues
If Err Then GoTo erFilt Else Err.Clear
i = rngCol.SpecialCells(xlVisible).count
If Err.Number = 0 And i > 0 Then GoTo fin
erFilt: MsgBox "Диапазон не отфильтрован!", vbCritical, "ОШИБКА ФИЛЬТРАЦИИ"
fin:
On Error GoTo 0
If Len(NFr) Then NumberFormat_Return rngCol, NF
Application.ScreenUpdating = True
End Sub
'===========================================================================================
Private Function NumberFormat_Replace(NF$) As String
If NF = "General" Or NF = "@" Then Exit Function
If NF Like "*yy*" Then
If NF Like "*h*" Then NumberFormat_Replace = "yyyy.mm.dd hh-mm-ss" Else NumberFormat_Replace = "yyyy-mm-dd"
Exit Function
End If
If NF Like "*h*:*" Then NumberFormat_Replace = "[h]:mm:ss": Exit Function
If NF Like "*0*.*0*" Then NumberFormat_Replace = "# ##0.00": Exit Function
End Function
'===========================================================================================
Private Function RangeToArray1x(ByVal rng As Range, ByVal NumFormatBase$) As Variant()
Dim dic As New Dictionary, ar As Range
Dim x, arr, i&
If Len(NumFormatBase) Then
For Each ar In rng.Areas
If ar.count = 1 Then
x = ar.Value2
ValueFormat x, NumFormatBase
x = dic.Item(x)
Else
arr = ar.Value2
For Each x In arr
ValueFormat x, NumFormatBase
x = dic.Item(x)
Next x
End If
Next ar
Else
For Each ar In rng.Areas
If ar.count = 1 Then
x = ar.Value2: If Len(x) = 0 Then x = "(пусто)"
x = dic.Item(x)
Else
arr = ar.Value2
For Each x In arr
If Len(x) = 0 Then x = "(пусто)"
x = dic.Item(x)
Next x
End If
Next ar
End If
RangeToArray1x = dic.Keys
End Function
'-------------------------------------------------------------------------------------------
Private Sub ValueFormat(iVal, NF$)
If Len(iVal) Then
iVal = iVal & delSearch & WorksheetFunction.text(iVal, NF)
Else
iVal = iVal & delSearch & "(пусто)"
End If
End Sub
'===========================================================================================
Private Sub NumberFormat_Return(rng As Range, ByVal NumFormatBase$)
Dim cl As Range
rng.NumberFormat = NumFormatBase
For Each cl In rng
If cl.EntireRow.Hidden Then cl.NumberFormat = NumFormatBase
Next cl
End Sub
'===========================================================================================
Private Function InsertDelim(delim$) As Boolean
Dim txt$
inp: txt = Application.InputBox("Введите разделитель:", "Получение данных", CStr(delim), Type:=2)
If txt = "False" Then Exit Function
If Len(txt) = 0 Then MsgBox "Вы не ввели разделитель!", vbCritical, "ОШИБКА ВВОДА": GoTo inp
delim = txt: InsertDelim = True
End Function
Модуль для работы с формой «ADD_FRM_Search_macro»
Код
Option Explicit
Option Private Module
'===========================================================================================
Public AAA_FRM_Search_Arr, AAA_FRM_Search_Mask$
'===========================================================================================
Function Start(tmpArr1x(), Optional Multy As Boolean, Optional FormName$, Optional DontSort As Boolean) As Boolean
If Not DontSort Then Sort tmpArr1x, 0, UBound(tmpArr1x)
AAA_FRM_Search_Arr = tmpArr1x: Erase tmpArr1x
If Multy Then ADD_FRM_Search.lb.MultiSelect = fmMultiSelectExtended
If Len(FormName) Then ADD_FRM_Search.Caption = FormName
ADD_FRM_Search.Show
If Not IsArray(AAA_FRM_Search_Arr) Then Exit Function
tmpArr1x = AAA_FRM_Search_Arr: Erase AAA_FRM_Search_Arr
Start = True
End Function
'===========================================================================================
Private Sub 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 Sort arr1x, l, j
If i < u Then Sort arr1x, i, u
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 22.05.2018
04.09.2019 10:31:05
Уважаемый, . Как теперь работать с надстройкой версии 1.5???? По чистому подключению и вставке кода в Модуль книги ничего не происходит! Если же делать как Вы давали подробные рекомендации для версии 1.0 ( с перетаскиванием, отметкой галочки и т.д.) то тоже не работает!!!! Опишите процесс установки подробно.
voxik-24, просто подключить, как обычную надстройку. Вызов горячими клавишами сработает в любой открытой книге. Больше ничего вставлять или перетаскивать не нужно — подключаем и работаем.
Конечно, если вы хотите внедрить функционал надстройки в книгу (файл), чтобы она работала самостоятельно без надстройки, то, конечно, нужно будет перенести всё её содержимое…
Изменено: - 04.09.2019 11:37:56
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 22.05.2018
04.09.2019 13:14:32
Уважаемый, . Есть одна проблема для решения: если в таблице в активной колонке по которой осуществляется поиск есть в какой-либо ячейке #Н/Д, то надстройка не срабатывает - выдает ошибку. Это можно как-то побороть?
v 1.6 • улучшена сортировка. Теперь, если формируется строка "базовое значение -> значение в формате", то сортировка происходит ОТДЕЛЬНО по базовым значениям (хорошо видно на поиске по денежным и прочим числовым форматам) • в процедуру по формированию строки поиска из видимого диапазона добавлена проверка на значения с ошибкой — теперь они исключаются из списка поиска • публичная константа разделителя для формирования строки с учётом формата теперь находится в модуле «ADD_FRM_Search_macro»
Основной модуль, в который были внесены изменения «ADD_FRM_Search_macro»
Код
Option Explicit
Option Private Module
'===========================================================================================
Public AAA_FRM_Search_Arr, AAA_FRM_Search_Mask$
Public Const AAA_FRM_Search_delim$ = " " ' Chr(32) & Chr(26) & Chr(32)
'===========================================================================================
Function Start(tmpArr1x(), Optional Multy As Boolean, Optional FormName$, Optional DontSort As Boolean) As Boolean
Dim arrVal(), arrInd() As Long, i&
If Not DontSort Then
If InStr(tmpArr1x(0), AAA_FRM_Search_delim) Then ' если есть разделитель, то собираем индексы и сортируем по левой (базовой) части
ReDim arrInd(UBound(tmpArr1x)): ReDim arrVal(UBound(arrInd))
For i = 0 To UBound(arrInd)
arrInd(i) = i: arrVal(i) = Left$(tmpArr1x(i), InStr(tmpArr1x(i), AAA_FRM_Search_delim) - 1)
If IsNumeric(arrVal(i)) Then arrVal(i) = --arrVal(i)
Next i
Sort_WithInd arrVal, arrInd, 0, UBound(arrInd)
Erase arrVal: ReDim AAA_FRM_Search_Arr(UBound(arrInd))
For i = 0 To UBound(arrInd)
AAA_FRM_Search_Arr(i) = tmpArr1x(arrInd(i))
Next i
Erase tmpArr1x: Erase arrInd
Else ' если разделителя нет то делаем обычную сортировку одномерного массива
Sort tmpArr1x, 0, UBound(tmpArr1x)
AAA_FRM_Search_Arr = tmpArr1x: Erase tmpArr1x
End If
End If
If Multy Then ADD_FRM_Search.lb.MultiSelect = fmMultiSelectExtended
If Len(FormName) Then ADD_FRM_Search.Caption = FormName
ADD_FRM_Search.Show
If Not IsArray(AAA_FRM_Search_Arr) Then Exit Function
tmpArr1x = AAA_FRM_Search_Arr: Erase AAA_FRM_Search_Arr
Start = True
End Function
'===========================================================================================
Private Sub 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 Sort arr1x, l, j
If i < u Then Sort arr1x, i, u
End Sub
'===========================================================================================
Sub Sort_WithInd(arrVal(), arrInd() As Long, l&, u&)
Dim x, y, i&, j&
i = l: j = u: x = arrVal((l + u) \ 2)
Do
Do While arrVal(i) < x: i = i + 1: Loop
Do While x < arrVal(j): j = j - 1: Loop
If i <= j Then
y = arrVal(i): arrVal(i) = arrVal(j): arrVal(j) = y
y = arrInd(i): arrInd(i) = arrInd(j): arrInd(j) = y
i = i + 1: j = j - 1
End If
Loop Until i > j
If l < j Then Sort_WithInd arrVal, arrInd, l, j
If i < u Then Sort_WithInd arrVal, arrInd, i, u
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 05.12.2016
08.09.2019 12:00:54
О! без привязки к определенным файлам! Супер! Спасибо! Jack Famous, только вот по скрытым и отфильтрованным ячейкам не ищет насколько я понял... Подскажите как обойти это ограничение?
DNC, пожалуйста. Это не ограничение, а логика — зачем искать значения, которые уже скрыты фильтром?… А так в строке Set=rngCol… убрать ".SpecalCells" и все после в строке. Ну или добавить строку, снимающую фильтр
Изменено: - 08.09.2019 13:48:08
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
v 1.7 • добавлена возможность поиска и вставки значений из отдельного списка Данные берутся из именованного диапазона "PRDX_rngList" активной книги. Вызов через "Ctrl + Shift + C" • добавлен обход ошибки при назначении/снятии "горячих клавиш" Это нужно для работы с книгой в защищённом режиме (надстройка при этом, разумеется, не работает, как и любые макросы) • сложная сортировка (по базовой части) при учёте формата — ускорена за счёт передачи уже готового массива (новая публичная переменная) • имена надстройки и модулей изменены • различные ускорения и улучшения
Модуль книги (надстройки)
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_Open()
On Error Resume Next
Application.OnKey "^+{Z}", "ADD_FRM_Search_Process.StartInsert"
Application.OnKey "^+{X}", "ADD_FRM_Search_Process.StartFilter"
Application.OnKey "^+{C}", "ADD_FRM_Search_Process.StartList"
End Sub
'===========================================================================================
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnKey "^+{Z}"
Application.OnKey "^+{X}"
Application.OnKey "^+{C}"
End Sub
Код из формы «ADD_FRM_Search»
Код
Option Explicit
'===========================================================================================
Dim arrFull()
'===========================================================================================
Property Get arrSym()
arrSym = Array("[", "]", "?", "#")
End Property
'===========================================================================================
'===========================================================================================
Private Sub UserForm_Initialize()
arrFull = AAA_FRM_Search_ArrFull: AAA_FRM_Search_ArrFull = 0
If Len(AAA_FRM_Search_Mask) Then
Me.tb_mask.Value = AAA_FRM_Search_Mask
Else
ArrayFilterByMask
End If
End Sub
'-------------------------------------------------------------------------------------------
Private Sub UserForm_Terminate()
AAA_FRM_Search_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): AAA_FRM_Search_ArrFull = arr: Unload Me
End Sub
'===========================================================================================
Private Sub lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ReDim AAA_FRM_Search_ArrFull(0)
AAA_FRM_Search_ArrFull(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
Модуль «ADD_FRM_Search_Main»
Код
Option Explicit
Option Private Module
'===========================================================================================
Public AAA_FRM_Search_ArrFull, AAA_FRM_Search_ArrBase, AAA_FRM_Search_Mask$
Public Const AAA_FRM_Search_delim$ = " " ' Chr(32) & Chr(26) & Chr(32)
'===========================================================================================
Function Start(tmpArr1x(), Optional Multy As Boolean, Optional FormName$, Optional DontSort As Boolean) As Boolean
Dim arrVal(), arrInd() As Long, i&
If Not DontSort Then
If IsArray(AAA_FRM_Search_ArrBase) Then ' если есть массив левой части, то собираем индексы и сортируем по ней
arrVal = AAA_FRM_Search_ArrBase: AAA_FRM_Search_ArrBase = Empty
ReDim arrInd(UBound(arrVal))
For i = 0 To UBound(arrInd): arrInd(i) = i: Next i
Sort_WithInd arrVal, arrInd, 0, UBound(arrInd)
Erase arrVal: ReDim AAA_FRM_Search_ArrFull(UBound(arrInd))
For i = 0 To UBound(arrInd)
AAA_FRM_Search_ArrFull(i) = tmpArr1x(arrInd(i))
Next i
Erase tmpArr1x: Erase arrInd
Else ' если второго массива нет, то делаем обычную сортировку одномерного массива
Sort tmpArr1x, 0, UBound(tmpArr1x)
AAA_FRM_Search_ArrFull = tmpArr1x: Erase tmpArr1x
End If
End If
If Multy Then ADD_FRM_Search.lb.MultiSelect = fmMultiSelectExtended
If Len(FormName) Then ADD_FRM_Search.Caption = FormName
ADD_FRM_Search.Show: If Not IsArray(AAA_FRM_Search_ArrFull) Then Exit Function
tmpArr1x = AAA_FRM_Search_ArrFull: Start = True: Erase AAA_FRM_Search_ArrFull
End Function
'===========================================================================================
Private Sub 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 Sort arr1x, l, j
If i < u Then Sort arr1x, i, u
End Sub
'===========================================================================================
Sub Sort_WithInd(arrVal(), arrInd() As Long, l&, u&)
Dim x, y, i&, j&
i = l: j = u: x = arrVal((l + u) \ 2)
Do
Do While arrVal(i) < x: i = i + 1: Loop
Do While x < arrVal(j): j = j - 1: Loop
If i <= j Then
y = arrVal(i): arrVal(i) = arrVal(j): arrVal(j) = y
y = arrInd(i): arrInd(i) = arrInd(j): arrInd(j) = y
i = i + 1: j = j - 1
End If
Loop Until i > j
If l < j Then Sort_WithInd arrVal, arrInd, l, j
If i < u Then Sort_WithInd arrVal, arrInd, i, u
End Sub
Модуль «ADD_FRM_Search_Process»
Код
Option Explicit
Dim arrFull(), rngCol As Range
Dim NF$, NFr$
Const rngName$ = "PRDX_rngList"
'-------------------------------------------------------------------------------------------
Private Sub ClearVariables()
On Error Resume Next
Set rngCol = Nothing
Erase arrFull: AAA_FRM_Search_ArrBase = Empty
NF = Empty: NFr = Empty
End Sub
'===========================================================================================
'===========================================================================================
Sub StartFilter()
Start
End Sub
'-------------------------------------------------------------------------------------------
Sub StartInsert()
Start True
End Sub
'-------------------------------------------------------------------------------------------
Sub StartList()
Start True, True
End Sub
'===========================================================================================
'===========================================================================================
Private Sub Start(Optional Insert As Boolean, Optional List As Boolean)
Dim sh As Worksheet, rng As Range, cl As Range
Dim x, lr&, i&, flagOut As Boolean
Static delInsert$: If Len(delInsert) = 0 Then delInsert = "; "
Set cl = ActiveCell: ClearVariables
If List Then 'если вставка из списка, то проверяем диапазон на наличие и пропускаем действия с активным столбцом
On Error Resume Next
Set rngCol = Evaluate(rngName)
If Err.Number <> 0 Then MsgBox "Именованный диапазон «" & rngName & "» ОТСУТСТВУЕТ в активной книге!", vbExclamation, "ОШИБКА СПИСКА": Exit Sub
On Error GoTo 0: GoTo method
End If
' получаем уникальные данные столбца и диапазон для фильтрации
Set sh = ActiveWorkbook.ActiveSheet
On Error Resume Next: Set x = sh.ListObjects(1): On Error GoTo 0
If TypeName(x) = "ListObject" Then
Set rng = x.Range
If Intersect(cl, rng) Is Nothing Then flagOut = True
lr = x.ListRows.Count + 1
Else
Set rng = sh.UsedRange
lr = sh.Cells(Rows.Count, cl.Column).End(xlUp).Row
If cl.Row > lr Then flagOut = True
End If
If flagOut And Not Insert Then Exit Sub
If rng.Cells(1, 1).Row <> 1 Or rng.Cells(1, 1).Column <> 1 Then MsgBox "Область данных должна начинаться с ПЕРВОЙ ячейки листа!", vbExclamation, "ОШИБКА РАСПОЛОЖЕНИЯ ДАННЫХ": Exit Sub
If lr < 3 Then MsgBox "В столбце «" & cl.Column & "» не более ОДНОГО значения!", vbExclamation, "НЕЧЕГО ВЫБИРАТЬ": Exit Sub
Set rngCol = sh.Cells(2, cl.Column).Resize(lr - 1).SpecialCells(xlVisible)
method:
If Insert Or List Then ' если вставка…
If Not RangeToArray1x() Then Exit Sub ' формируем массив
If List Then x = "из СПИСКА «" & rngName & "»" Else x = "из АКТИВНОГО СТОЛБЦА"
If Not ADD_FRM_Search_Main.Start(arrFull, True, "Форма для поиска значений " & x & " и ВСТАВКИ их в АКТИВНУЮ ЯЧЕЙКУ") Then Exit Sub
If Len(NFr) Then GetLeft ' если было преобразование, то берём только левые части
If UBound(arrFull) > 0 Then ' если выбрано более 1 значения…
If Not InsertDelim(delInsert) Then Exit Sub ' выбираем разделитель для вставки нескольких значений
cl.Value2 = Join(arrFull, delInsert): Exit Sub ' вставляем текстовую сцепку и выходим
Else
x = arrFull(0): If IsNumeric(x) Then x = --x ' если похоже на число, то преобразовываем
cl.Value2 = x: Exit Sub ' вставляем одно выбранное и выходим
End If
End If
' фильтруем
NF = cl.NumberFormat: NumberFormat_Replace
If Not RangeToArray1x(True) Then Exit Sub
If Not ADD_FRM_Search_Main.Start(arrFull, True, "Форма для поиска значений из АКТИВНОГО СТОЛБЦА и его ФИЛЬТРАЦИИ") Then Exit Sub
If Len(NFr) Then ' если был разделитель в списке поиска, то берём из каждого элемента ЛЕВУЮ (значение без форматов) часть до разделителя и преобразуем в текстовый
GetLeft True
Else ' если разделителя нет, то просто преобразуем в текстовый
For i = 0 To UBound(arrFull)
arrFull(i) = CStr(arrFull(i))
Next i
End If
Application.ScreenUpdating = False
If Len(NFr) Then rngCol.NumberFormat = "@"
On Error Resume Next
rng.AutoFilter field:=cl.Column, Criteria1:=arrFull, Operator:=xlFilterValues
If Err Then GoTo erFilt Else Err.Clear
i = rngCol.SpecialCells(xlVisible).Count
If Err.Number = 0 And i > 0 Then GoTo fin
erFilt: MsgBox "Диапазон не отфильтрован!", vbCritical, "ОШИБКА ФИЛЬТРАЦИИ"
fin:
On Error GoTo 0
If Len(NFr) Then NumberFormat_Return
Application.ScreenUpdating = True
End Sub
'===========================================================================================
'===========================================================================================
Private Sub NumberFormat_Replace()
If NF = "General" Or NF = "@" Then Exit Sub
If NF Like "*yy*" Then
If NF Like "*h*" Then NFr = "yyyy.mm.dd hh-mm-ss" Else NFr = "yyyy-mm-dd"
Exit Sub
End If
If NF Like "*h*:*" Then NFr = "[h]:mm:ss": Exit Sub
If NF Like "*0*.*0*" Then NFr = "### ### ### ### ##0.00"
End Sub
'-------------------------------------------------------------------------------------------
Private Sub NumberFormat_Return()
Dim cl As Range
rngCol.NumberFormat = NF
For Each cl In rngCol
If cl.EntireRow.Hidden Then cl.NumberFormat = NF
Next cl
End Sub
'===========================================================================================
Private Function RangeToArray1x(Optional WithEmpty As Boolean) As Boolean ' получаем 1 массив или 2 (в случае учитывания формата)
Dim dic As New Dictionary, ar As Range
Dim x, arr, i&, n&, flag As Boolean
RangeToArray1x = True
' первый цикл — сбор одномерного уникального массива с исключением ошибок (и пустых, если нужно)
For Each ar In rngCol.Areas
arr = ar.Value2
If IsArray(arr) Then
For Each x In arr
If Not IsError(x) Then
If Len(x) Then x = dic(x) Else flag = True
End If
Next x
Else
If Not IsError(arr) Then
If Len(arr) Then x = dic(arr) Else flag = True
End If
End If
Next ar
Erase arr
If dic.Count = 0 Then
If Not WithEmpty Or Not flag Then MsgBox "Нечего вставлять", vbInformation, "ПУСТО": RangeToArray1x = False: Exit Function
ReDim arrFull(0): If Len(NFr) Then arrFull(0) = AAA_FRM_Search_delim & "(пусто)"
Exit Function
End If
arrFull = dic.Keys: dic.RemoveAll: n = UBound(arrFull)
If WithEmpty And flag Then ReDim Preserve arrFull(n + 1)
If Len(NFr) = 0 Then Exit Function
' второй цикл — преобразование данных, если нужно учесть формат
AAA_FRM_Search_ArrBase = arrFull
If WithEmpty And flag Then arrFull(n + 1) = AAA_FRM_Search_delim & "(пусто)"
For i = 0 To n
arrFull(i) = arrFull(i) & AAA_FRM_Search_delim & WorksheetFunction.Text(arrFull(i), NFr)
Next i
End Function
'===========================================================================================
Private Sub GetLeft(Optional ToText As Boolean)
Dim i&
If ToText Then
For i = 0 To UBound(arrFull)
arrFull(i) = CStr(Left$(arrFull(i), InStr(arrFull(i), AAA_FRM_Search_delim) - 1))
Next i
Else
For i = 0 To UBound(arrFull)
arrFull(i) = Left$(arrFull(i), InStr(arrFull(i), AAA_FRM_Search_delim) - 1)
If IsNumeric(arrFull(i)) Then arrFull(i) = --arrFull(i)
Next i
End If
End Sub
'===========================================================================================
Private Function InsertDelim(delim$) As Boolean
Dim txt$
inp: txt = Application.InputBox("Введите разделитель:", "Получение данных", CStr(delim), Type:=2)
If txt = "False" Then Exit Function
If Len(txt) = 0 Then MsgBox "Вы не ввели разделитель!", vbCritical, "ОШИБКА ВВОДА": GoTo inp
delim = txt: InsertDelim = True
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 22.05.2018
15.09.2019 22:13:14
Уважаемый, . Надстройка все лучше и лучше... Но есть еще поле для развития Было бы здорово если Вам удалось бы реализовать следующее: При вставке с именованного списка "PRDX_rngList" активной книги, выбранные позиции вставляются в одну ячейку, разделяясь указанным пользователем разделителем...применение такой вставки даже не знаю для чего, ну может в каких то отдельных случаях , а хотелось бы чтобы вставка происходила построчно *в столбик" и тогда вставка приобретает логический и практический смысл.
voxik-24: есть еще поле для развития … применение такой вставки даже не знаю для чего … а хотелось бы чтобы вставка происходила построчно "в столбик" и тогда вставка приобретает логический и практический смысл
ваше заявление — одна из самых необъективных вещей, которые я когда-либо слышал Неужели вы не понимаете, что то, что нужно вам может быть абсолютно ненужно и непонятно кому-то ещё?… В создании формы я руководствовался необходимостью и достаточностью, а также минимальными рисками потери данных пользователя. То, что вы хотите сделать может легко "затереть" данные пользователя, в то время как с помощью текущей версии можно добиться того же, просто запустив несколько раз. Впрочем — если хотите, то сделать это очень просто: замените блок со строки 66 до строки 72 (в модуле «ADD_FRM_Search_Process»)
КОД
Код
' старый блок
If UBound(arrFull) > 0 Then ' если выбрано более 1 значения…
If Not InsertDelim(delInsert) Then Exit Sub ' выбираем разделитель для вставки нескольких значений
cl.Value2 = Join(arrFull, delInsert): Exit Sub ' вставляем текстовую сцепку и выходим
Else
x = arrFull(0): If IsNumeric(x) Then x = --x ' если похоже на число, то преобразовываем
cl.Value2 = x: Exit Sub ' вставляем одно выбранное и выходим
End If
' новый блок
ReDim AAA_FRM_Search_ArrBase(1 To UBound(arrFull)+1, 1 To 1)
For i=0 To UBound(arrFull)
If IsNumeric(arrFull(i)) Then
AAA_FRM_Search_ArrBase(i+1) = --arrFull(i)
Else
AAA_FRM_Search_ArrBase(i+1) = arrFull(i)
Next i
cl.Resize(UBound(arrFull)+1,1).Value2=AAA_FRM_Search_ArrBase
Exit Sub
писал тут, а не в редакторе и не тестил. Вставка происходит БЕЗ учёта видимости ячеек, то есть от активной и ниже, сколько данных было выбрано…
Изменено: - 16.09.2019 10:41:01
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 22.05.2018
17.09.2019 11:36:29
Уважаемый, . Никоим образом не хотел Вас "нагнуть" под свои потребы.... Понимаю, как ревностно Вы относитесь к своей работе (делаете нужное дело на безвозмездной основе и еще есть те, кто хотел бы чтобы настройка и кофе варила). Но еще раз, (надеюсь, уже остыв ) неужели Вы не видите полезность вставки столбиком? Н-р: есть огромный перечень, а нужно быстро вставить по порядку n-ное количество наименований расположенных в разных частях этого списка. В Вашей надстройке это пара секунд только для проставления галочек и вуаля - дело сделано. Но даже если Вы не согласны с моим мнением, все равно спасибо за труды. Ваша надстройка работает на Ваш статус как специалиста высокого уровня. Только не забрасывайте ее. Хорошего дня.
voxik-24, я не буду встраивать в неё этот инструмент по-дефолту, а если хотите себе такой "швейцарский нож" в лучших традициях китайцев — я вам уже написал, что нужно сделать
Цитата
voxik-24: есть огромный перечень, а нужно быстро вставить по порядку n-ное количество наименований расположенных в разных частях этого списка
а как вы себе представляете поисковую маску, при которой "расположенные в разных частях этого списка наименования" все под неё подойдут? Для такой реализации нужен "контейнер" для хранения выделенного (при поиске по различным маскам), проверка на скрытые ячейки при вставке и т.д. Это по-хорошему. Мне такое пока не нужно и не интересно
Изменено: - 17.09.2019 12:18:23
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 18.04.2016
17.06.2020 15:57:18
Здравствуйте Jack Famous, а есть ли возможность усовршенствовать форму так, что-бы она могла работать, если фильтр выставлен не с первой строки. Что я имею ввиду (файл приложен). Если строки фильтра имеет значение более ежели 1, то форма не срабатывает, а выдает окошко
lobaty: есть ли возможность усовершенствовать форму так, что-бы она могла работать, если фильтр выставлен не с первой строки
разумеется, но тогда возникает вопрос "какую строку считать заголовками". Кроме того, для меня это способ проверки, т.к. любая таблица у меня начинается с первой строки. Адаптация формы под конкретные нужны возможна - это платно, пишите в личку
P.S.: возможно я уберу из формы проверку первой строки, но точно не в ближайшее время Пока попробуйте написать что-то в A1 - может поможет (нет времени разбираться)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Было бы здорово если Вам удалось бы реализовать следующее: При вставке с именованного списка "PRDX_rngList" активной книги, выбранные позиции вставляются в одну ячейку, разделяясь указанным пользователем разделителем...применение такой вставки даже не знаю для чего, ну может в каких то отдельных случаях , а хотелось бы чтобы вставка происходила построчно *в столбик" и тогда вставка приобретает логический и практический смысл.
