Макросы в 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