Удалить строки с определенным словом

[Вячеслав76]

Добрый день. Помогите пожалуйста доработать макрос. Нужно в таблице удалить строки содержащие определенное слово. Сейчас пользуюсь вот этим:

Sub Удаление_заказа()

Dim ra As Range, delra As Range, ТекстДляПоиска As String
Application.ScreenUpdating = False
For Each ra In ActiveSheet.UsedRange.Rows
If Not ra.Find("Приемка Леруа", , xlValues, xlPart) Is Nothing Then
If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next
If Not delra Is Nothing Then delra.EntireRow.Delete

End Sub

Сейчас понадобилось, удалять строки не с одним словом, а которые содержат еще два слова. (Пусть это будет яблоко и апельсин, для примера). Понятно, что можно просто написать три аналогичных макроса (с разными словами для поиска) и запускать их друг за другом. Но хотелось бы понять, как это сделать в одном макросе. То есть сначала удаляем все строки со словом "приемка Лерау", потом все строки со словом "яблоко", потом все строки со словом "апельсин". Можно одновременно удалить)) Спасибо))

[Aleksandr H.]

Option Explicit

Sub Удаление_заказа()
    Dim sCriterias(2) As String
    sCriterias(0) = "Приемка Леруа"
    sCriterias(1) = "яблоко"
    sCriterias(2) = "апельсин"
    Dim idx As Integer
    
    
    Dim ra As Range, delra As Range, ТекстДляПоиска As String
    Application.ScreenUpdating = False
    For idx = LBound(sCriterias) To UBound(sCriterias)
        For Each ra In ActiveSheet.UsedRange.Rows
            If Not ra.Find(sCriterias(idx), , xlValues, xlPart) Is Nothing Then
                If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
            End If
        Next
    Next
    If Not delra Is Nothing Then delra.EntireRow.Delete
    
End Sub

[Вячеслав76]

Добрый день. Еще раз спасибо огромное всем за помощь. Появилась новая задача, и как к ней подступить, я вообще не знаю.. Есть таблица, нужно сделать следующее:
1) оставить первые 5 строк без изменений (так как это шапка таблицы)
2) Начиная с 6й строки нужно удалить все строки, в которых в столбце "D" есть любое слово. Слова могут меняться, но главный признак - оставить только ту строчку, где в колонке "D"=пусто.
3) После этого удалить все строки, где в другой колонке "Е" нет слова - "брак" .
В итоге остается таблице, где "D"=(Пустая ячейка) и "Е" = БРАК.
Таблица большая, в среднем 1000 -1200 строк.
Часть таблицы во вложении.

Помогите пожалуйста с решением.

[Aleksandr H.]

так-же как и большинство задач - цикл с перебором

Option Explicit

Sub DoSomething()
    Dim rng As Range
    Dim iLastRow As Integer
    Dim iRow As Integer
    With ActiveSheet
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For iRow = 6 To iLastRow
            If Not (Trim$(.Cells(iRow, "D").Value2) = "" And UCase(Trim$(.Cells(iRow, "E").Value2)) = "БРАК") Then
                If rng Is Nothing Then
                    Set rng = .Cells(iRow, "D")
                Else
                    Set rng = Union(rng, .Cells(iRow, "D"))
                End If
            End If
        Next
        If Not rng Is Nothing Then rng.EntireRow.Delete
    End With
End Sub

[Вячеслав76]

Спасибо огромное Все как обычно - работает)))

[Вячеслав76]

Можно уточнить только один вопрос? Решил для себя попробовать заменить слово "Брак" на другое слово в этой же колонке - "Новый поставщика". Думал, все просто. А оно не работает Сносит всю таблицу. Почему? В чем подвох?)

Sub Новый_Поставщика()
Dim rng As Range
Dim iLastRow As Integer
Dim iRow As Integer
With ActiveSheet
iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For iRow = 6 To iLastRow
If Not (Trim$(.Cells(iRow, "D").Value2) = "" And UCase(Trim$(.Cells(iRow, "E").Value2)) = "Новый поставщика") Then
If rng Is Nothing Then
Set rng = .Cells(iRow, "D")
Else
Set rng = Union(rng, .Cells(iRow, "D"))
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
End Sub"

[Aleksandr H.]

Читаем про UCASE и делаем выводы

https://docs.microsoft.com/en-us/off...ucase-function

[Вячеслав76]

Я в английском не силен Но со словарем попробую разобраться. Спасибо

[Aleksandr H.]

Да там просто, первая строка все разберет

https://translate.google.com/?hl=uk&....&op=translate

[Вячеслав76]

Добрый день. Спасибо за ссылку. Я разобрался, почитал и все заработало. Подскажите еще два вопроса пожалуйста. Столкнулся с тем, что файл коллеги открывают в "защищенном просмотре". И чтобы макрос заработал, я дописал строку:-

Application.ActiveProtectedViewWind ow.Edit

Все хорошо, работает. Но если девчонки нажимают кнопку "разрешить редактирование", то макрос на этой строчке встает. Объяснить коллегам, что макрос нужно запускать только в "защищенном просмотре" пока не получается Можно написать что то вместо - Application.ActiveProtectedViewWind ow.Edit - чтобы макрос запускался независимо, в защищенном режиме открыт документ или уже нажата кнопка "разрешить редактирование?
И второе. Попросили меня из таблицы где удалялись строки, сделать две на разных листах. Казалось бы, что может быть проще. Копируем лист. На одном запускаем макрос со словами "БРАК", на другом макрос со словами "НОВЫЙ ПОСТАВЩИКА". Но нет. Ругается, что дублируются объявление.. Но почему? Я же запускаю макросы на разных листах. Пока обошел это двумя макросами, но хотелось бы разобраться

Application.ScreenUpdating = False
Application.ActiveProtectedViewWind ow.Edit
ActiveWindow.TabRatio = 0.28
Sheets("TDSheet").Name = "Брак"
Sheets("Брак").Copy Before:=Sheets(1)
Sheets("Брак (2)").Name = "Новый поставщик"
Dim rng As Range
Dim iLastRow As Integer
Dim iRow As Integer
With ActiveSheet
iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For iRow = 6 To iLastRow
If Not (Trim$(.Cells(iRow, "D").Value2) = "" And UCase(Trim$(.Cells(iRow, "E").Value2)) = "НОВЫЙ ПОСТАВЩИКА") Then
If rng Is Nothing Then
Set rng = .Cells(iRow, "D")
Else
Set rng = Union(rng, .Cells(iRow, "D"))
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
Sheets("Брак").Activate

Dim rng As Range
Dim iLastRow As Integer
Dim iRow As Integer
With ActiveSheet
iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For iRow = 6 To iLastRow
If Not (Trim$(.Cells(iRow, "D").Value2) = "" And UCase(Trim$(.Cells(iRow, "E").Value2)) = "БРАК") Then
If rng Is Nothing Then
Set rng = .Cells(iRow, "D")
Else
Set rng = Union(rng, .Cells(iRow, "D"))
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub