MyTetra Share
Делитесь знаниями!
Поиск подходящих строк в двумерном массиве
31.12.2017
16:01
Текстовые метки: SearchArray,Search,Array
Раздел: VBA - Array

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

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

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
  • 22942 просмотра
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования