Private Sub CommandButton1_Click()
x = Range("A1:J" & Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(x) 'расчет номера 1 строки реестра
If x(i, 1) = "ГНН-0001" And CDate(x(i, 3)) = #1/1/2023# Then Exit For
Next i
With Cells(i, 1).Resize(UBound(ArrAutofilterNew(x, "1=" & "ГНН-0001", "3=" & #1/1/2023#)), 10).Interior
'раскраска ячеек
End With
Debug.Print ArrAutofilterNew_GetRfirst(x, "1=" & "ГНН-0001", "3=" & #1/1/2023#)
End Sub
Function ArrAutofilterNew_GetRfirst(ByRef arr, ParamArray args() As Variant) As Variant ' Новая версия функции ArrAutofilter, от января 2021 года. © ExcelVBA.ru
Dim RowsCount&, i As Long, j As Long, arrCheck As Variant
arrCheck = GetArrCheck(arr, RowsCount, args)
For i = LBound(arr, 1) To UBound(arr, 1) ' снова перебираем все строки массива
If arrCheck(i) Then ' если строка ранее помечена как подходящая
ArrAutofilterNew_GetRfirst = i
Exit Function
End If
Next i
End Function
Function ArrAutofilterNew(ByRef arr, ParamArray args() As Variant) As Variant ' Новая версия функции ArrAutofilter, от января 2021 года. © ExcelVBA.ru
Dim RowsCount&, i As Long, j As Long, arrCheck As Variant, ro&
arrCheck = GetArrCheck(arr, RowsCount, args)
ReDim newarr(1 To RowsCount&, LBound(arr, 2) To UBound(arr, 2)) ' формируем новый массив
For i = LBound(arr, 1) To UBound(arr, 1) ' снова перебираем все строки массива
If arrCheck(i) Then ' если строка ранее помечена как подходящая
ro& = ro& + 1 ' вычисляем номер строки в новом массиве
For j = LBound(arr, 2) To UBound(arr, 2)
newarr(ro&, j) = arr(i, j) ' заполняем массив значениями из исходного
Next j
End If
Next i
ArrAutofilterNew = newarr ' возвращаем результат
End Function
Function GetArrCheck(ByRef arr, RowsCount&, ParamArray args() As Variant) As Variant
On Error Resume Next
GetArrCheck = False ' возвращаемое значение в случае ошибки
If UBound(args) = -1 Then Debug.Print "Array filtering error: filters required": Exit Function
ReDim Filters(1 To UBound(args(0)) + 1, 1 To 2)
Dim i&, ColumnToCheck&, FiltersCount&, j&: Err.Clear: i& = UBound(arr, 2)
If Err.Number > 0 Then Debug.Print "Array filtering error: two dimensional array required": Exit Function
For i& = LBound(args(0)) To UBound(args(0)) ' перебираем все параметры фильтрации
If Not IsMissing(args(0)(i&)) Then
If args(0)(i&) Like "#*=*" Then ' распознаем параметры фильтрации
FiltersCount& = FiltersCount& + 1
Filters(FiltersCount&, 1) = Val(Split(args(0)(i&), "=")(0)) ' столбец массива
Filters(FiltersCount&, 2) = Split(args(0)(i&), "=", 2)(1) ' маска для значения
Else ' неверно заданный фильтр
Debug.Print "ArrAutofilterNew error: invalid filter «" & args(0)(i&) & "»"
End If
End If
Next i&
If FiltersCount& = 0 Then Debug.Print "Array filtering error: all filters are empty": Exit Function
ReDim arrCheck(LBound(arr, 1) To UBound(arr, 1)) As Boolean ' для результатов проверки
For i = LBound(arr, 1) To UBound(arr, 1) ' перебираем все строки массива, и проверяем их
arrCheck(i) = True
For j& = 1 To FiltersCount& ' перебираем все параметры фильтрации
If Not (arr(i, Filters(j&, 1)) Like Filters(j&, 2)) Then arrCheck(i) = False: Exit For
Next j&
RowsCount& = RowsCount& - arrCheck(i) ' увеличиваем счётчик подходящих строк на 1
Next i
If RowsCount& = 0 Then Exit Function ' выход, если нет ни одной подходящей строки в массиве
GetArrCheck = arrCheck
End Function
|
))
