Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для удаления строк, если в столбцах есть конкретный текст
 
#1
15.06.2021 18:36:48
Добрый день.
Есть прайс, который обрабатывается большим макросом. В процессе обработки надо удалить строки, в ячейках которых есть определённый текст, в данном случае, слово "наклейки" в разных падежах и начинающееся и с заглавных и со строчных букв. На этом форуме нашел похожий макрос от  Mershik, немного доработал и работает. Но дело в том, что нужное слово встречается в 3 колонках и начинается с большой и малой букв.
Поэтому я 5 раз вставляю этот макрос в свой, чтобы убрать все строки.
Как я понимаю, можно эту обработку сделать сразу, выделив всю таблицу, но у меня не получается...
Заранее большое спасибо всем, кто сможет помочь в этом.
Ниже часть кода макроса, связанная как раз с удалением ненужным строк. В приложении таблица, в том виде, какой получается к началу работы макроса по удалению строк.
Код
Sub nakl_B()
'удаление строк с "накл" в столбце B
Dim cell As Range, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
If Cells(i, 2) Like "*накле*" Then
    If cell Is Nothing Then
        Set cell = Cells(i, 1)
    Else
        Set cell = Union(cell, Cells(i, 1))
    End If
End If
Next i
    If Not cell Is Nothing Then cell.EntireRow.Delete
'удаление строк с "Накл" в столбце B
Dim cell2 As Range, i2 As Long, lr2 As Long
lr2 = Cells(Rows.Count, 1).End(xlUp).Row
For i2 = 2 To lr2
If Cells(i2, 2) Like "*Накле*" Then
    If cell2 Is Nothing Then
        Set cell2 = Cells(i2, 1)
    Else
        Set cell2 = Union(cell2, Cells(i2, 1))
    End If
End If
Next i2
    If Not cell2 Is Nothing Then cell2.EntireRow.Delete
'удаление строк с "накл" в столбце D
Dim cell3 As Range, i3 As Long, lr3 As Long
lr3 = Cells(Rows.Count, 1).End(xlUp).Row
For i3 = 2 To lr3
If Cells(i3, 4) Like "*накле*" Then
    If cell3 Is Nothing Then
        Set cell3 = Cells(i3, 1)
    Else
        Set cell3 = Union(cell3, Cells(i3, 1))
    End If
End If
Next i3
    If Not cell3 Is Nothing Then cell3.EntireRow.Delete
'удаление строк с "накл" в столбце R
Dim cell4 As Range, i4 As Long, lr4 As Long
lr4 = Cells(Rows.Count, 1).End(xlUp).Row
For i4 = 2 To lr4
If Cells(i4, 18) Like "*накле*" Then
    If cell4 Is Nothing Then
        Set cell4 = Cells(i4, 1)
    Else
        Set cell4 = Union(cell4, Cells(i4, 1))
    End If
End If
Next i4
    If Not cell4 Is Nothing Then cell4.EntireRow.Delete
'удаление строк с "Накл" в столбце R
Dim cell5 As Range, i5 As Long, lr5 As Long
lr5 = Cells(Rows.Count, 1).End(xlUp).Row
For i5 = 2 To lr5
If Cells(i5, 18) Like "*Накле*" Then
    If cell5 Is Nothing Then
        Set cell5 = Cells(i5, 1)
    Else
        Set cell5 = Union(cell5, Cells(i5, 1))
    End If
End If
Next i5
    If Not cell5 Is Nothing Then cell5.EntireRow.Delete
End Sub
 
 
 
 
#2
15.06.2021 20:05:44
karlson7, так?
Код
Sub nakl_B()
Dim cell As Range, i As Long, lr As Long, arr, n As Long
arr = Array(2, 4, 18)
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
For n = LBound(arr) To UBound(arr)
If Cells(i, arr(n)) Like "*накле*" Then
    If cell Is Nothing Then
        Set cell = Cells(i, 1): Exit For
    Else
        Set cell = Union(cell, Cells(i, 1)): Exit For
    End If
End If
Next n
Next i
    If Not cell Is Nothing Then cell.EntireRow.Delete
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#3
15.06.2021 20:45:42
Цитата
Mershik написал:
karlson7 , так?
Спасибо большое! Работает на 99%.
В приложенном файле я прайс сильно сократил, чтобы можно было залить на форум.
И в сокращенном варианте все работает. в полном прайсе более 5000 строк, 388 ячеек надо удалить, но 2 сточки остаются. Я проверил, вроде все русские буквы, ничего подозрительного нет, но нет хотят удаляться никак.
В этих двух ячейках один и тот же текст, вот кусок
Цитата
"Дайте ребёнку больше самостоятельности, создайте творческую атмосферу. Наклеивание картинок не только сделает процесс обучения увлекательным занятием, но и разовьёт мелкую моторику и "
если написать "наклеивание", то все работает.
Причем "старый" код тоже удаляет полностью
Код
Sub BN()
Dim cell5 As Range, i5 As Long, lr5 As Long
lr5 = Cells(Rows.Count, 1).End(xlUp).Row
For i5 = 2 To lr5
If Cells(i5, 18) Like "*Ķąźėå*" Then
    If cell5 Is Nothing Then
        Set cell5 = Cells(i5, 1)
    Else
        Set cell5 = Union(cell5, Cells(i5, 1))
    End If
End If
Next i5
    If Not cell5 Is Nothing Then cell5.EntireRow.Delete
End sub
 
 
 
#4
15.06.2021 20:51:37
Покажите то что не удаляется в файле
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#5
15.06.2021 21:02:05
Цитата
Mershik написал:
Покажите то что не удаляется в файле
Ячейки R14 и R15,
это часть файла уже после выполнения макроса
 
 
 
#6
15.06.2021 21:10:14
karlson7, в этом файле предложенный мной макрос не отрабатывает указанные Вами ячейки?
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#7
15.06.2021 21:13:59
Цитата
Mershik написал:
karlson7 , в этом файле предложенный мной макрос не отрабатывает указанные Вами ячейки?
Да
 
 
 
#8
15.06.2021 21:18:47
karlson7, тогда так
Код
Sub nakl_B()
Dim cell As Range, i As Long, lr As Long, arr, arr2, n As Long, x As Long
arr = Array(2, 4, 18)
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
For n = LBound(arr) To UBound(arr)
x = InStr(1, Cells(i, arr(n)), "накле", 1)
If x > 0 Then
    If cell Is Nothing Then
        Set cell = Cells(i, 1): Exit For
    Else
        Set cell = Union(cell, Cells(i, 1)): Exit For
    End If
End If
Next n
Next i
    If Not cell Is Nothing Then cell.EntireRow.Delete
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#9
15.06.2021 21:25:03
Цитата
Mershik написал:
тогда так
Да, сейчас удаляются все строки.
Спасибо большое!
 
 
 
Страницы: 1
Наверх