Sub УдалениеСтрокПоНесколькимУсловиям() Dim ra As Range, delra As Range Application.ScreenUpdating = False ' отключаем обновление экрана
' ищем и удаляем строки, содержащие заданный текст ' (можно указать сколько угодно значений, и использовать подстановочные знаки) УдалятьСтрокиСТекстом = Array("Наименование *", "Количество", _ "текст?", "цен*сти", "*78*")
' перебираем все строки в используемом диапазоне листа For Each ra In ActiveSheet.UsedRange.Rows ' перебираем все фразы в массиве For Each word In УдалятьСтрокиСТекстом ' если в очередной строке листа найден искомый текст If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then ' добавляем строку в диапазон для удаления If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra) End If Next word Next
' если подходящие строки найдены, то: (оставьте одну из 2 следующих строк) If Not delra Is Nothing Then delra.EntireRow.Hidden = True ' скрываем их If Not delra Is Nothing Then delra.EntireRow.Delete ' удаляем их
[/vba]
Мне нужно оставить только строки которые содержат UE_WM16, UE_WM15
Я подставил значения для поиска и удаления и вместо всего листа поменял диапазон поиска на Range("H:H"). С одним условием работает все нормально. хоть и долго. Но при двух макрос удаляет все данные.Подскажите может я что то не так поменял?
Здравствуйте. в сети нашел макрос [vba]
Код
Sub УдалениеСтрокПоНесколькимУсловиям() Dim ra As Range, delra As Range Application.ScreenUpdating = False ' отключаем обновление экрана
' ищем и удаляем строки, содержащие заданный текст ' (можно указать сколько угодно значений, и использовать подстановочные знаки) УдалятьСтрокиСТекстом = Array("Наименование *", "Количество", _ "текст?", "цен*сти", "*78*")
' перебираем все строки в используемом диапазоне листа For Each ra In ActiveSheet.UsedRange.Rows ' перебираем все фразы в массиве For Each word In УдалятьСтрокиСТекстом ' если в очередной строке листа найден искомый текст If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then ' добавляем строку в диапазон для удаления If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra) End If Next word Next
' если подходящие строки найдены, то: (оставьте одну из 2 следующих строк) If Not delra Is Nothing Then delra.EntireRow.Hidden = True ' скрываем их If Not delra Is Nothing Then delra.EntireRow.Delete ' удаляем их
[/vba]
Мне нужно оставить только строки которые содержат UE_WM16, UE_WM15
Я подставил значения для поиска и удаления и вместо всего листа поменял диапазон поиска на Range("H:H"). С одним условием работает все нормально. хоть и долго. Но при двух макрос удаляет все данные.Подскажите может я что то не так поменял?Zoor
Здравствуйте. Этот макрос должен чуток быстрее отработать.
[vba]
Код
Sub УдалениеСтрокПоНесколькимУсловиям() Dim delra As Range Application.ScreenUpdating = False ' отключаем обновление экрана ' ищем и удаляем строки, содержащие заданный текст ' (можно указать сколько угодно значений) УдалятьСтрокиСТекстом = Array("UE_WM16", "UE_WM15") ' перебираем все строки в используемом диапазоне листа With ActiveSheet LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row dx = .Range("H1:H" & LastRow) For i = 1 To UBound(dx) For Each word In УдалятьСтрокиСТекстом If InStr(1, dx(i, 1), word, vbTextCompare) > 0 Then ' добавляем строку в диапазон для удаления If delra Is Nothing Then Set delra = .Rows(i) Else Set delra = Union(delra, .Rows(i)) exit for End If Next Next
End With ' если подходящие строки найдены, то: (оставьте одну из 2 следующих строк) ' If Not delra Is Nothing Then delra.EntireRow.Hidden = True ' скрываем их If Not delra Is Nothing Then delra.EntireRow.Delete ' удаляем их Application.ScreenUpdating = True End Sub
[/vba]
Здравствуйте. Этот макрос должен чуток быстрее отработать.
[vba]
Код
Sub УдалениеСтрокПоНесколькимУсловиям() Dim delra As Range Application.ScreenUpdating = False ' отключаем обновление экрана ' ищем и удаляем строки, содержащие заданный текст ' (можно указать сколько угодно значений) УдалятьСтрокиСТекстом = Array("UE_WM16", "UE_WM15") ' перебираем все строки в используемом диапазоне листа With ActiveSheet LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row dx = .Range("H1:H" & LastRow) For i = 1 To UBound(dx) For Each word In УдалятьСтрокиСТекстом If InStr(1, dx(i, 1), word, vbTextCompare) > 0 Then ' добавляем строку в диапазон для удаления If delra Is Nothing Then Set delra = .Rows(i) Else Set delra = Union(delra, .Rows(i)) exit for End If Next Next
End With ' если подходящие строки найдены, то: (оставьте одну из 2 следующих строк) ' If Not delra Is Nothing Then delra.EntireRow.Hidden = True ' скрываем их If Not delra Is Nothing Then delra.EntireRow.Delete ' удаляем их Application.ScreenUpdating = True End Sub