Данная функция ищет в массиве все строки, похдодящие под заданные критерии, и возвращает список номеров подходящих строк (через запятую)
Option Compare Text Function ArrAutofilter(ByRef arr, ParamArray args() As Variant) As String ' получает по ссылке массив ARR для фильтрации ' и список критериев фильтрации в формате "3=некий текст" (номер столбца, "=", искомое значение) ' возвращает текстовую строку - список номеров подходящих строк (через запятую) Dim Index As Long, OK As Boolean, ComparedColumn As Long, res As String If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical, _ "Ошибка в функции ArrAutofilter": Exit Function For Index = LBound(args) To UBound(args) ' перебираем все параметры фильтрации If Not IsMissing(args(Index)) Then If GetAutofilterArgument(args(Index), ComparedColumn, res) Then If (ComparedColumn > UBound(arr, 2)) Or (ComparedColumn < LBound(arr, 2)) Then _ ArrAutofilter = ArrAutofilter & "В массиве нет столбца с номером " & _ ComparedColumn & vbNewLine Else ArrAutofilter = ArrAutofilter & "Неверно сформирована строка фильтрации: " & _ args(Index) & vbNewLine End If Else ArrAutofilter = ArrAutofilter & (Index + 1) & "-й аргумент фильтрации отсутствует" & _ vbNewLine End If Next Index If Len(ArrAutofilter) Then MsgBox ArrAutofilter, vbCritical, "Ошибка в функции ArrAutofilter" ArrAutofilter = "": Exit Function End If For i = LBound(arr, 1) To UBound(arr, 1) ' перебираем все строки массива OK = True For Index = LBound(args) To UBound(args) ' перебираем все параметры фильтрации ' получаем параметры фильтрации X = GetAutofilterArgument(args(Index), ComparedColumn, res) If Not (arr(i, ComparedColumn) Like res) Then OK = False: Exit For Next Index If OK Then ArrAutofilter = ArrAutofilter & "," & i Next i ArrAutofilter = Mid$(ArrAutofilter, 2) End Function Function GetAutofilterArgument(ByVal arg, ByRef col As Long, ByRef searchStr As String) As Boolean col = 0: searchStr = "" If UBound(Split(arg, "=")) < 1 Then Exit Function ' нет знака = sCol = Split(arg, "=")(0): If Len(sCol) = 0 Or Not sCol Like String(Len(sCol), "#") Then _ Exit Function ' номер столбца не соответствует searchStr = Mid$(arg, Len(sCol) + 2): col = Val(sCol) If col > 0 Then GetAutofilterArgument = True End Function Sub ПримерИспользования() arr = shs.UsedRange.Value Debug.Print ArrAutofilter(arr, "2=Для мужчин", "4=Джинсы", "73=?*") End Sub
Несколько изменённая функция - работает также, только возвращает результат в виде отфильтрованного массива:
Function ArrAutofilterEx(ByRef arr, ParamArray args() As Variant) As Variant ' получает по ссылке массив ARR для фильтрации ' и список критериев фильтрации в формате "3=некий текст" (номер столбца, "=", искомое значение) ' возвращает двумерный массив с подходящими строками Dim Index As Long, OK As Boolean, ComparedColumn As Long, res As String If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical, _ "Ошибка в функции ArrAutofilter": Exit Function For Index = LBound(args) To UBound(args) ' перебираем все параметры фильтрации If Not IsMissing(args(Index)) Then If GetAutofilterArgument(args(Index), ComparedColumn, res) Then If (ComparedColumn > UBound(arr, 2)) Or (ComparedColumn < LBound(arr, 2)) Then _ ArrAutofilter = ArrAutofilter & "В массиве нет столбца с номером " & _ ComparedColumn & vbNewLine Else ArrAutofilter = ArrAutofilter & "Неверно сформирована строка фильтрации: " & _ args(Index) & vbNewLine End If Else ArrAutofilter = ArrAutofilter & (Index + 1) & "-й аргумент фильтрации отсутствует" & _ vbNewLine End If Next Index If Len(ArrAutofilter) Then MsgBox ArrAutofilter, vbCritical, "Ошибка в функции ArrAutofilter" ArrAutofilterEx = "": Exit Function End If Dim coll As New Collection For i = LBound(arr, 1) To UBound(arr, 1) ' перебираем все строки массива OK = True For Index = LBound(args) To UBound(args) ' перебираем все параметры фильтрации ' получаем параметры фильтрации X = GetAutofilterArgument(args(Index), ComparedColumn, res) If Not (arr(i, ComparedColumn) Like res) Then OK = False: Exit For Next Index If OK Then coll.Add i Next i ' формируем новый массив ReDim newarr(1 To coll.Count, LBound(arr, 2) To UBound(arr, 2)) For i = 1 To coll.Count ro = coll(i) For j = LBound(arr, 2) To UBound(arr, 2): newarr(i, j) = arr(ro, j): Next j Next i ArrAutofilterEx = newarr End Function Function GetAutofilterArgument(ByVal arg, ByRef col As Long, ByRef searchStr As String) As Boolean col = 0: searchStr = "" If UBound(Split(arg, "=")) < 1 Then Exit Function ' нет знака = sCol = Split(arg, "=")(0): If Len(sCol) = 0 Or Not sCol Like String(Len(sCol), "#") Then _ Exit Function ' номер столбца не соответствует searchStr = Mid$(arg, Len(sCol) + 2): col = Val(sCol) If col > 0 Then GetAutofilterArgument = True End Function
Пример использования:
Sub FilterExample() On Error Resume Next Dim arr As Variant ' отбираем только нужные строки из диапазона a2:t200, ' где текст в третьем столбце начинается с "asy" arr = ArrAutofilterEx(Range("a2:t200").Value, "3=asy*") ' создаем лист, вставляем на него результат Worksheets.Add.Range("a1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End Sub
Комментарии
Спасибо. Сам к такому же решению пришел.
Еще может поможете в одном вопросе? Условия для фильтра задаются в текстбоксах от 1го до 6ти. Изначально думал собрать со всех текстбоксов в одну строку с разделителем все условия. Затем через Split получить массив условий и подставить этот массив в функцию ArrAutofilterEx(). Однако не получается. Пока остановился на варианте - после получения массива условий, через определения кол-ва элементов этого массива, при помощи Select Case 6 различных вариантов вызова функции ArrAutofilterEx () с кол0вом аргументов условий от 1го до 6ти. Получается некрасивая, но работающая конструкция:
Select Case lR
Case Is = 0
arMatTemp = ArrAutofilterEx(garMat, arMat(0))
Case Is = 1
arMatTemp = ArrAutofilterEx(garMat, arMat(0), arMat(1))
Case Is = 2
arMatTemp = ArrAutofilterEx(garMat, arMat(0), arMat(1), arMat(2))
Case Is = 3
arMatTemp = ArrAutofilterEx(garMat, arMat(0), arMat(1), arMat(2), arMat(3))
Case Is = 4
arMatTemp = ArrAutofilterEx(garMat, arMat(0), arMat(1), arMat(2), arMat(3), arMat(4))
Case Is = 5
arMatTemp = ArrAutofilterEx(garMat, arMat(0), arMat(1), arMat(2), arMat(3), arMat(4), arMat(5))
Может как-то можно передать на вход массив условий или ещё как-нибудь?
Иван, попробуйте заменить строку
на что-то типа такого
Отличная функция. Есть вопрос. У меня в двухмерном массиве есть элементы равные Null (получаю массив из рекордсета). И эта функция отбирает строки с этими элементами в новый массив.
Т.е. например две строки массива
15 Труба 89
18 Задвижка Null
условие "2=89". Ожидаю отфильтрует и выведет только первую строку, а получаю и первую, и вторую.
я так понимаю, что получается "Null Like 89" и это обрабатывается как True? Как изменить код?
В итоге поиск "?" по столбцу в массиве так и не заработал, как я ни бился.
"~" не помогает как и писал ранее.
Решил вопрос путем создания следующего алгоритма:
1. Поиск "?" в массиве и замена на "\".
2. Фильтрация массива по "\".
3. Замена "\" обратно на "?".
4. Вывод результатов.
В ячейке указан ? + или -.
Если в качестве критерия поиска по столбцу указываешь 1=~? функция не работает
Чтобы найти текст 123*456?789
ищите такое значение: 123~*456~?789
(добавляем тильду ~ перед спецсимволами типа * и ?)
Добрый день!
Прошу прощения за сумбурные сообщения. Осваиваю VBA..
Все же не подскажете, как с помощью функции либо другого метода можно найти ? или * в значениях массива?
Разобрался. В качестве параметров сьедает массив.
А как быть с поисков вопросительного знака в массиве?
~ не работает..
Добрый день!
Пользователь вводит критерии поиска в форму.
Номер выбранного столбца и критерий поиска сохраняются в два массива.
Просматривая оба массива формирую строку поиска. Пробовал формировать ее по разному и с кавычками и без.
Так и не могу понять как нужно. Подскажите, как корректно сформировать строку поиска?
For i = 1 To UBound(MassNumber) Step 1
If MassZnach(i) = "" Then
Else
If searchrow = "" Then
searchrow = Chr(34) & MassNumber(i) & " = " & MassZnach(i) & Chr(34)
Else
searchrow = searchrow & ", " & Chr(34) & MassNumber(i) & "=" & MassZnach(i) & Chr(34)
End If
End If
Next i
MsgBox searchrow
filterResult = ArrAutofilterEx(МассивПубликаций, searchrow)
Можно, - только надо немного код подправить (например, где выполняется сравнение при помощи оператора =, поставить < или >)
Добрый день Игорь!
Возможно ли отфильтровать по критерию больше или меньше?. Спасибо
Первой строкой в ваш макрос (или в мою функцию) добавьте
И снова вопрос к автору :)
Вариант решения для поиска разных значений в одном индексе нашел.
Но столкнулся с непонятной проблемой - если ищем по значению, которого нет в исходном массиве, то стопорится, ругаясь "run-time error '9' subscript out of range" на строку "ReDim newarr(1 To coll.Count, LBound(arr, 2) To UBound(arr, 2))".
Как обойти ошибку при таком раскладе? :)
Такая возможность в этой функции не предусмотрена.
Конкретно для вашего случая, - можно написать так:
А в общем случае, - никак (надо дорабатывать макрос)
Уважаемый автор, а если необходимо сделать выборку по одному и тому же номеру столбца, но с несколькими условиями?
arr = ArrAutofilterEx(Range("b12:vf21860").Value, "1=SLS6S", "1=SLS4S") - не срабатывает :(
здравствуйте, Константин.
Так будет работать:
Добрый день.
Подскажите пожалуйста, каким образом для второй функции можно организовать ввод "некого текста" по которому происходит фильтрация через InputBox?
Вариант вида:
temp = InputBox("введите некий текст")
arr = ArrAutofilterEx(Range("a2:t200").Value, "3=temp")
не работает. Начинает фильтрацию по слову temp
Спасибо.
спасибо большое, все работает как надо
Здравствуйте, Сергей.
Да, можно:
(знак вопроса обозначает 1 любой символ)
Здравствуйте, можно ли объединить две строки в одну?
arr = ArrAutofilterEx(Range("a2:d4003").Value, "1=A-PK.##")
ark = ArrAutofilterEx(Range("a2:d4003").Value, "1=A-##.##")хотелось бы чтобы находило и те и те значения.
Добрый день у меня возникла такая проблема.
Столкнулся с такой проблемой. Не знаю как подойти и как ее решить с помощью макроса. Сравнить два массива и подобрать значения.
Эти массивы все время меняются (их формирует другая программа) и по количеству столбцов они не одинаковые. Причем 1 массив является основным (эталонным). Мне нужно сравнить 1 массив со вторым. Причем со второго массива подобрать значение наиболее подходящее для значения из первого массива т.е. 590 должно подойти 600. И так для каждого значения 1 массива.
И результат вывести на другой лист.
Есть два массива
1массив 2массив
590 и 800
516 2450
1939 900
419 1200
590 600
516 500
1939 450
419 320
210
Все, понял свою ошибку:
Я в окно watches для просмотра значения массива добавлял массив из процедуры,
т.е. выделял правой клавишей переменную a() и в выскакивающем меню делал Add to watch
при этом во время работы процедуры данный массив был доступен (Context был указан как наименование данной процедуры, например, Module1.Макрос1), а при выходе a() терял свои значения и становился .
Когда же я сделал Add to watch для переменной в объявлении, т.е. Public a As Variant
Добавился массив, значения которого были доступны после запуска функции заполнения (Contex был указан, как module1).
Здравствуйте, Алексей.
Вы все правильно в коде написали, массив должен быть доступен из других макросов.
Добрый день, замечательная функция.
Подскажите, пожалуйста, возможно ли сделать, чтобы массив из функций или процедур был доступен в течение длительного времени и нескольких обращений, в т.ч. из пользовательских функций, для примера:
При открытии файла загружаем некий объем из листа в массив (10000 строк * 50)
Очень бы хотелось в дальнейшем работать с данным массивом, использовать к нему функцию фильтрования (например при обращении из пользовательской функции).
Возможно ли, чтобы этот массив не "забывался" vba и его не приходилось загружать заново?
Дело в том, что как только я выхожу из функции загрузки из range в массив (через объявление переменной variant):
public a as variant
sub p()
a= Range("a3:t10000").Value
end sub
после окончания процедуры массив a() становится недоступным
Ну так а что вы написали в параметрах фильтрации?
Вы оставляете строки, в которых первый столбец равен «Week Starting From», и первый же столбец ничему не равен...
Как такое может быть?
1) если используете 2 фильтра - они должны быть для разных столбцов
2) если применяете фильтр - надо указывать значение после знака =
PS: Если функция работала неделю назад - значит, проблема явно не в ней.
Добрый вечер. Несколько дней назад функция работала, сейчас ругается "error 13. Type dismatch" на строчку:
If Not (arr(i, ComparedColumn) Like res) Then OK = False: Exit For (выделяет до слова OK).
Для запуска функции использую следующий Sub:
Sub Filter()
Dim arr As Variant, i As Long, a As String, b As String, arr2 As Variant
a = "1=Week Starting From"
b = "1="
arr = Sheets("Details").UsedRange.Value
arr2 = ArrAutofilterEx(arr, a, b)
Cells.Select
Selection.Delete Shift:=xlUp
[a1].Resize(UBound(arr2, 1), UBound(arr2, 2)).Value = arr2
End Sub
Спасибо
Большое спасибо
Никита, в которой функции?
Вообще, отключение ошибок рулит)
Желательно эту же строку дописать ещё в начало функции
(а не только в свой макрос, перед вызовом функции)
Код может выглядеть так:
Игорь, подскажите пожалуйста, как отключить сообщение об ошибке при получении на выходе пустого массива?
Хорошо, в ближайшее время сделаю пример.
На самом деле, функция очень полезная, если часто пишете макросы.
Я использую эту функцию в 40-50% всех своих макросов.
Вкратце, как ей пользоваться: (речь про функцию ArrAutofilterEx, возвращающую отфильтрованный массив. Первая функция, ArrAutofilter, крайне редко когда может пригодиться)
1) считываем данные в массив:
arr = range("a2:f100").ValueТаким образом, мы получили двумерный массив arr из 99 строк и 6 столбцов
2) Теперь наша задача - оставить в массиве только те строки,
где в первом столбце содержится текст «товар», в 4 столбце находится значение «Да»,
а значение 6-го столбца совпадает со значением переменной txt.
С использованием функции ArrAutofilterEx, это делается при помощи одной строки кода:
В результате, в массиве arr останется не 99 строк, а, к примеру, только 40 (подходящих под все 3 условия).
3) Выгружаем результат из массива arr на другой лист, или используем в расчётах.
Добрый день!
Присоединяюсь к вопросу Алексея - можно посмотреть работу второй функции на примере? Постоянно выдает "type mismatch"
Как полльзоваться этой функцией?
Здравствуйте, можно посмотреть файл с примером где используется вторая функция? У меня она постоянно выдает ошибку "Это не массив!" при попытке выделить массив.
Понял, спасибо за информацию. Принял к сведению
А что вы понимаете под критерием? Номер столбца для сортировки?
Так для этого есть отдельный макрос сортировки
Добрый день Игорь, а как сделать функцию по сортировке строк массива с помощью одного критерия? Предположим вводить его через InputBox. Я думаю это было бы интересно и другим читателям. Очень интересный сайт. Спасибо
Отправить комментарий