mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Поиск подходящих строк в двумерном массиве

Данная функция ищет в массиве все строки, похдодящие под заданные критерии, и возвращает список номеров подходящих строк (через запятую)

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. Поиск "?" в массиве и замена на "\".
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)

Можно, - только надо немного код подправить (например, где выполняется сравнение при помощи оператора =, поставить < или >)

Добрый день Игорь!
Возможно ли отфильтровать по критерию больше или меньше?. Спасибо

Первой строкой в ваш макрос (или в мою функцию) добавьте

On Error Resume Next

И снова вопрос к автору :)
Вариант решения для поиска разных значений в одном индексе нашел.
Но столкнулся с непонятной проблемой - если ищем по значению, которого нет в исходном массиве, то стопорится, ругаясь "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=SLS[46]S")

А в общем случае, - никак (надо дорабатывать макрос)

Уважаемый автор, а если необходимо сделать выборку по одному и тому же номеру столбца, но с несколькими условиями?
arr = ArrAutofilterEx(Range("b12:vf21860").Value, "1=SLS6S", "1=SLS4S") - не срабатывает :(

здравствуйте, Константин.
Так будет работать:

arr = ArrAutofilterEx(Range("a2:t200").Value, "3=" & temp)

Добрый день.
Подскажите пожалуйста, каким образом для второй функции можно организовать ввод "некого текста" по которому происходит фильтрация через InputBox?
Вариант вида:
temp = InputBox("введите некий текст")
arr = ArrAutofilterEx(Range("a2:t200").Value, "3=temp")
не работает. Начинает фильтрацию по слову temp
Спасибо.

спасибо большое, все работает как надо

Здравствуйте, Сергей.
Да, можно:

arr = ArrAutofilterEx(Range("a2:d4003").Value, "1=A-??.##")

(знак вопроса обозначает 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() становится недоступным

Ну так а что вы написали в параметрах фильтрации?

a = "1=Week Starting From"
b = "1="

Вы оставляете строки, в которых первый столбец равен «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

Спасибо

Большое спасибо

Никита, в которой функции?
Вообще, отключение ошибок рулит)

On Error Resume Next 

Желательно эту же строку дописать ещё в начало функции
(а не только в свой макрос, перед вызовом функции)

Код может выглядеть так:

On Error Resume Next 
arr="": arr = ArrAutofilterEx(arr, "1=*товар*", "4=Да", "6=" & txt)
if not isarray(arr) then exit sub ' строк не нашлось...

' а тут код работы с выборкой (массив arr точно не пустой)

Игорь, подскажите пожалуйста, как отключить сообщение об ошибке при получении на выходе пустого массива?

Хорошо, в ближайшее время сделаю пример.

На самом деле, функция очень полезная, если часто пишете макросы.
Я использую эту функцию в 40-50% всех своих макросов.

Вкратце, как ей пользоваться: (речь про функцию ArrAutofilterEx, возвращающую отфильтрованный массив. Первая функция, ArrAutofilter, крайне редко когда может пригодиться)

1) считываем данные в массив:

arr = range("a2:f100").Value

Таким образом, мы получили двумерный массив arr из 99 строк и 6 столбцов

2) Теперь наша задача - оставить в массиве только те строки,
где в первом столбце содержится текст «товар», в 4 столбце находится значение «Да»,
а значение 6-го столбца совпадает со значением переменной txt.
С использованием функции ArrAutofilterEx, это делается при помощи одной строки кода:

arr = ArrAutofilterEx(arr, "1=*товар*", "4=Да", "6=" & txt)

В результате, в массиве arr останется не 99 строк, а, к примеру, только 40 (подходящих под все 3 условия).

3) Выгружаем результат из массива arr на другой лист, или используем в расчётах.

Добрый день!
Присоединяюсь к вопросу Алексея - можно посмотреть работу второй функции на примере? Постоянно выдает "type mismatch"

Как полльзоваться этой функцией?

Здравствуйте, можно посмотреть файл с примером где используется вторая функция? У меня она постоянно выдает ошибку "Это не массив!" при попытке выделить массив.

Понял, спасибо за информацию. Принял к сведению

А что вы понимаете под критерием? Номер столбца для сортировки?

Так для этого есть отдельный макрос сортировки

Добрый день Игорь, а как сделать функцию по сортировке строк массива с помощью одного критерия? Предположим вводить его через InputBox. Я думаю это было бы интересно и другим читателям. Очень интересный сайт. Спасибо

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
      _   _   _   ____    ____             ___  
__| | | \ | | | _ \ | _ \ __ _ ( _ )
/ _` | | \| | | |_) | | | | | / _` | / _ \
| (_| | | |\ | | _ < | |_| | | (_| | | (_) |
\__,_| |_| \_| |_| \_\ |____/ \__,_| \___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.