Добрый день! Задача такова: имеется таблица размером (A1:A1000). В каждой ячейке множество разных слов. Нужно написать макрос, чтобы, ввел в ячейку C1 искомое слово, например, "желтый" и из 1000 строк, были бы видны лишь те строки в которых находится искомое слово - "желтый". Также чтобы можно было применить второй уровень фильтрации, например, в D1 введу, "15", то должны остаться лишь те строки , в которых присутствуют слова "желтый" и "15".
Sub Анархия15()
Dim x As Integer
With ActiveSheet
x = .Cells(1, .Columns.Count).End(xlToLeft).Column
If x < 3 Then Exit Sub
Dim crr As Variant
If x = 3 Then
ReDim crr(1 To 1, 1 To 1)
Else
crr = .Range(.Cells(1, 3), .Cells(1, x))
End If
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, 1))
Dim flag As Boolean
.Cells.EntireRow.Hidden = False
For y = 2 To UBound(arr, 1)
flag = False
For x = 1 To UBound(crr, 2)
If InStr(arr(y, 1), crr(1, x)) > 0 Then
flag = True
Exit For
End If
Next
If flag = False Then .Cells(y, 1).EntireRow.Hidden = True
Next
End With
End Sub
Дмитрий(The_Prist) Щербаков написал: И что уже пробовали сделать? Что именно не получается? И сколько таких уровней:
уровня 3. (если имеет значение, то ищу конкретные 27 слов). данный макрос к сожалению ищет совпадение лишь из одного столбца. У меня диапазон таблицы А7:A1000 , а поиск нужно осуществлять в ячейках C1,D1,E1, (цвет, размер. вес товара).
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A2:I5")) Is Nothing Then
On Error Resume Next
ActiveSheet.ShowAllData
Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion
End If
End Sub
Sub Анархия16()
Dim x As Integer
With ActiveSheet
x = .Cells(1, .Columns.Count).End(xlToLeft).Column
If x < 3 Then Exit Sub
.Cells.EntireRow.Hidden = False
Dim crr As Variant
If x = 3 Then
ReDim crr(1 To 1, 1 To 1)
crr(1, 1) = .Cells(1, 3).Value
Else
crr = .Range(.Cells(1, 3), .Cells(1, x))
End If
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, 1))
Dim flag As Boolean
For y = 2 To UBound(arr, 1)
flag = True
For x = 1 To UBound(crr, 2)
If InStr(arr(y, 1), crr(1, x)) = 0 Then
flag = False
Exit For
End If
Next
If flag = False Then .Cells(y, 1).EntireRow.Hidden = True
Next
End With
End Sub
'Это в модуль листа.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Rows(1)) Is Nothing Then
Анархия15
End If
End Sub