Надстройка создана на основе формы с поиском и служит для поиска и вставки одного или нескольких значений из активного столбца по аналогии с инструментом из PLEX'а Выпадающий список с автопоиском
v 1.0 Инфа по подключению есть в соседней теме (не хочу копипаст устраивать), да и принцип полностью одинаков для версии фильтра 1.1, кроме действий с выбранными из формы значениями. Там активный столбец по ним фильтруется, а тут они вставляются в ячейку через разделитель (если 2 и более) или просто вставляется, если выбрано одно
Вызов в примере (модуль книги)
Код
Option Explicit
'===========================================================================================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal target As Range, Cancel As Boolean)
Cancel = True: FRM_Search_FindInActiveColumn.Start
End Sub
Единственный немного отличающийся модуль «FRM_Search_FindInActiveColumn»
Код
Option Explicit
Const delim$ = " " ' Chr(32) & Chr(26) & Chr(32)
'===========================================================================================
Sub Start()
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 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
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
Последняя актуальная версия надстройки/кода теперь в родительской теме
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, найденное количество надо бы запретить ввод данных.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Юрий М, потому что то - про фильтр, а это про вставку и обе - на основе одной и той же формы. Поэтому три темы с перекрёстными ссылками. Больше делать не планирую, если что То "зачем всё в одну кучу сваливаешь", то "зачем плодишь дубликаты"…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: То "зачем всё в одну кучу сваливаешь", то "зачем плодишь дубликаты"…
Джек, может хватит уже? Три темы с одинаковым названием - это нормально? Да ещё огрызаетесь и обсуждаете действия модераторов. Пункт 3.10 правил никто не отменял.
Юрий М: Три темы с одинаковым названием - это нормально?
если они на основе одного инструмента, то почему бы нет…
Юрий М, я правда не понимаю, на основе чего вы принимаете решения. Темы разные - предлагаете всё свалить в одну и постоянно путаться, что именно обсуждаем? В чём моя вина? Ей богу - определитесь уже. Я не против ваших действий, просто не понимаю логики… Противоречия
А самое забавное, что мы с Виктором обсуждали разделение тем, просто делить тогда было нечего, а теперь 2 решения отдельно развились в соответствующих им темах и снова прищли в виде готового решения в базовую. Ваше видение какое?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Юрий М, но ведь там про "фильтр" и очень много специфики в связи с этим. Я сначала вёл оба "примера" в родительской теме про форму, но потом стало очевидно, что тема в свалку превращается. Ну правда ведь…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Извините за глупый вопрос. Прикрутил в автозапуска PaRADoX_FormSearch.xlam. При открытии Excel запускается и PaRADoX, но даблклик в ином файле кроме приведенных здесь не работает. Можно ли даблклик сделать глобальным, либо же хоть как-то назначить свой хотккей для вызова окна "Поиск и выбор значений из списка".
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄