|
Поиск подходящих строк в двумерном массиве
- Макросы VBA 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
|
