mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Удаление (скрытие) строк по условию

макрос удалит на листе все строки, в которых содержится искомый текст:

(пример - во вложении ConditionalRowsDeleting.xls)

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

Чтобы вместо удаления просто скрыть такие строки, замените строку

If Not delra Is Nothing Then delra.EntireRow.Delete

на
If Not delra Is Nothing Then delra.EntireRow.Hidden=TRUE


Расширенная версия этого макроса - с использованием UserForm для ввода искомого значения

(пример - в файле ConditionalRowsDeletingUsingUserform.xls)


Function ПоискСтрокПоУсловию(ByVal ТекстДляПоиска As String, Optional HideOnly As Boolean) As Long
    ' функция получает в качестве параметра ТекстДляПоиска (можно использовать символы * и ?)
    ' Если HideOnly = TRUE, то строки, содержащие в ячейках ТекстДляПоиска, скрываются,
    ' иначе (HideOnly = FALSE - по умолчанию) - удаляются
    ' Функция возвращает количество удалённых строк
    Dim ra As Range, delra As Range
    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
    On Error Resume Next: ПоискСтрокПоУсловию = delra.Areas.Count ' количество найденных строк
    
    If Not delra Is Nothing Then    ' если подходящие строки найдены - скрываем или удаляем их
        If HideOnly Then delra.EntireRow.Hidden = True Else delra.EntireRow.Delete
    End If
End Function


Ещё один вариант кода, позволяющего выполнять поиск (с последующим удалением или скрытием строк) сразу по нескольким условиям:

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    ' удаляем их
End Sub

ВложениеРазмерЗагрузкиПоследняя загрузка
ConditionalRowsDeleting.xls24 КБ70809 часов 37 минут назад
ConditionalRowsDeletingUsingUserform.xls45.5 КБ1182 дня 22 часа назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Относительно вопроса от 9 Сен 2011 - 20:12. (пишет тот же гость)
М.б. это происходит потому что мы назначаем массив с данными которые описываем функцией array, а соотв другой массив, который и нужно удалить он не видит???

Пробую использовать простую функцию циклическую, работает только при одном условии!! При нескольких уже нет, почему так происходит, подскажите, пжта, как можно решить эту проблему???!

Sub test()
    For i = 1 To 15000
        If (ActiveCell.Value = "AL.M.ME" Or ActiveCell.Value = "ALPEX") Then
            Selection.EntireRow.Delete
            i = i - 1
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Next i
End Sub

Добрый день!
Вы знаете, пробовал и в одном месте убрать NOT, и во всех где оно стоит, но ничего не получается. Подскажите, пжта, что делаю неправильно? Цель - удалить строки, в которых НЕ содержится текст. СпасибО!

Sub УдалениеСтрокПоНесколькимУсловиям()
    Dim ra As Range, delra As Range
   ' ищем и удаляем строки, содержащие заданный текст
   ' (можно указать сколько угодно значений, и использовать подстановочные знаки)
   УдалятьСтрокиСТекстом = Array("AL.M.ME", "Новотранс Юг")
 
    ' перебираем все строки в используемом диапазоне листа
   For Each ra In ActiveSheet.UsedRange.Rows
        ' перебираем все фразы в массиве
       For Each word In УдалятьСтрокиСТекстом
            ' если в очередной строке листа найден искомый текст
           If 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
 
    If delra Is Nothing Then delra.EntireRow.Delete    ' удаляем их
End Sub

Это на 26 комментарий замечание.

Почему-то если значений для исключения больше одного, то удаляет все строки.

а если условия в виде выделенного диапазона или в форме ввести возможность добавления диапазона как условия?

Много условий можно записать в таком виде:

    ' (можно указать сколько угодно значений, и использовать подстановочные знаки)
    УдалятьСтрокиСТекстом = Array("Условие 1", "Условие 2", _
                                  "Условие 3", "Условие 4", "Условие 5", "Условие 6", _
                                  "Условие 7", "Условие 8", "Условие 9", _
                                  "Условие 11", "Условие 12", "Условие 13", "Условие 14")

Проблема в том, что я не знаю, как в данном макросе сделать удобным ввод нескольких условий (а то давно бы реализовал)

Вариантов тут несколько, но они все недостаточно удобны:

1) писать все условия в коде - в принципе неправильно

2) вводить условия через форму ввода - можно, но там надо либо делать много полей (а это куча кода), либо одно большое поле, но тогда не будет видно, где заканчивается предыдущее условие, и начинается следующее (если текст условий не влазит в форму по длине в одну строку)
Да ещё и специально сохранять условия требуется - чтобы при следующем запуске макроса их снова не вводить.

3) загружать список условий с листа - но придётся где-то в макросе прописывать код, с какого листа скаких ячеек брать данные

4) текстовый файл со списком условий - тоже не совсем удобно может быть

и т.д. и т.п.

Одной строчкой все условия у меня не влезают, excel начинает ругаться. Я их разбил но незнаю как их объединит, чтобы макрос по очереди все условия отрабатывал?
Спасибо

Sub УдалениеСтрокПоНесколькимУсловиям()
Dim ra As Range, delra As Range
Application.ScreenUpdating = False ' отключаем обновление экрана

' ищем и удаляем строки, содержащие заданный текст
' (можно указать сколько угодно значений, и использовать подстановочные знаки)
УдалятьСтрокиСТекстом = Array("Наименование *", "Количество", _
"текст?", "цен*сти", "*78*")
УдалятьСтрокиСТекстом = Array("Наименование *", "Количество", _
"текст?", "цен*сти", "*78*")
УдалятьСтрокиСТекстом = 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 ' удаляем их
End Sub

Спасибо )

Нет. Надо просто убрать NOT:

If ra.Find(ТекстДляПоиска, , xlValues, xlPart) Is Nothing Then

Подскажите, пожалуйста. Сейчас макрос работает по принципу:
'если подходящие строки найдены - удаляем их

Что нужно изменить в коде макроса, чтобы он работал:
'если подходящие строки найдены - оставляем их, остальные удаляем

?

Мой очень маленький опыт работы в VBA подсказывает мне, что нужно оператор Not заменить на XOR. Правильно ли это?

Sub Find_n_Hide()
Dim iListCount As Integer
Dim iCtr As Integer
Application.ScreenUpdating = False
iListCount = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
Do Until ActiveCell = ""
   For iCtr = 1 To iListCount
     If ActiveCell.EntireRow.Hidden = False Then
      If ActiveCell.Row <> Cells(iCtr, 2).Row Then
         If ActiveCell.Text = Cells(iCtr, 2).Text Then
            Cells(iCtr, 2).EntireRow.Hidden = True
               iCtr = iCtr + 1
         End If
      End If
      End If
   Next iCtr
   ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Готово!"
End Sub

Сей код на VBA скрывает повторяющиеся ячейки. Выкладываю сюда по той причине, что во время поиска решения этой задачи меня завело на этот ресурс. Надеюсь, что код пригодится тем, кто столкнулся с аналогичной проблемой. Написан на базе старого макроса из MKB для 2000 VBA, который удалял строки, с моими изменениями и исправлениями под VBA 2007 Оффиса.

Искренне благодарен Вам, Игорь! Вы очень помогли!

Сделал пример с формой ввода строки:

 

Для этого пришлось превратить макрос в функцию:

Sub УдалениеСтрокПоУсловию(ByVal ТекстДляПоиска As String)
    Dim ra As Range, delra As Range
    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

Код вызова функции из формы:

Private Sub CommandButton1_Click()
    txt = Trim(Me.TextBox1): If Len(txt) = 0 Then Exit Sub    ' если текст не введён
    УдалениеСтрокПоУсловию txt
End Sub

Пример можете посмотреть в этом файле: http://excelvba.ru/XL_Files/Sample__24-07-2011__20-20-44.zip

Простите, я полный ноль в VBA. Не подскажете как "ТекстДляПоиска" подвязать к TextBox UserForm? Т.е. вызывать например "Удаление контакта", вставляя нужное выражение.

Все вышесказанное под UserForm бы оформить...было бы здорово

Юлия, для этих вопросов существуют форумы: http://excelvba.ru/forum
Обратитесь туда - и ответ не заставит себя ждать.

Добрый день у меня два вопроса:
1. Как можно описать здесь проблему не вклиниваясь в другие темы. (по другому как то не получается)
2. Вопрос возможно не по этой теме, но для меня актуальный. Есть два рабочих файла, обмен информацией происходит при помощи ADO
Path = "\\Dispetcher\svk\ÊÐÑ\" & Year(ActiveSheet.Range("I3").Value) & "\" & mnth(Month(ActiveSheet.Range("I3").Value)) & "\" & "ÊÐÑ" & mnth(Month(ActiveSheet.Range("I3").Value)) & ".xlsm;"
MsgBox Path

strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & Path _
& "Extended Properties=""Excel 8.0;HDR=YES"";"

Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.CursorType = adOpenStatic

conn.Open strConn$

Я решила файл который является исходным сохранить в другом формате xlsm, в результате выходит ошибка
Run-time error 2147467259 (80004005).

Как лучше поступить : а) вернуть все как было б) сохранить принимающий информацию файл также в новом формате
в) исправить код, только в каком месте ?

можно написать макроc который это все и заменяет!
и Заменять Q_ на пустое место!

Правильно мыслите)
Вам поможет простейший макрос, который решит проблему за долю секунды:

Sub Убрать_Q_сПробелом()
    Range("a:a").Replace "Q ", "", xlPart
End Sub

Я придумал)

спасибо за Cntr + H !

можно написать максрок который это все и заменяет!
=)

и Заменять Q_
на пустое место!
=)

ексель всемогущ
=)

Оперативно!=)
Спасибо большое!)

Добавлю ваш сайт в Popular)
и прорекламирую в соц сетях )

Просто Ctrl + H каждый день нажимать для списка из 500-800 ячеек не хочется
одной кнопочкой бы все это дело сделать)

мой код созданный самим редактором:

' разделяем тикеры и букву Q

Range("A2:A3000").Select
Selection.TextToColumns Destination:=Range("A2"), DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(2, 1)), TrailingMinusNumbers:=True

' перенос столбца с тикерами на столбец с буквами Q, второй столбец остается пустым
Application.CutCopyMode = False
Range("B2:B3000").Cut Destination:=Range("A2:A3000")
Range("A2:A3000").Select

а как сделать чтобы удалялись ячейки которые целиком содержат текст

Очень просто - замените к коде макроса все xlPart на xlWhole, и поиск будет вестись по полному, а не частичному совпадению 

Т.е. код после замены будет выглядеть так: ...Find(word, , xlValues, xlWhole)...

как удалить первые два знака в столбце ( буква Q и пробел после нее)

Тут вообще макрос на нужен - выделяем столбце, жмём Ctrl + H для вывода диалогового окна "Найти и заменить",
и меняем "Q " на пустую строку.

И еще сразу вопрос сюда задам
сорри что не в тему
есть столбец
Q art
Q man
Q kt

как удалить первые два знака в столбце ( буква Q и пробел после нее)
я реализовал через разделение шиксированной ширины и перемешение обратно
минус - второй столбец должен быть пустым
или придется париться с его сохранением в буфер и обратно вставлять

american17@mail.ru

Добрый день!
классный макрос

а как сделать чтобы
удалялись ячейки которые целиком содержат текст

пример:

AEM
EM
EMERSON
AMETEK

нужно удалить только одну ячейку EM
а макрос удаляет все строчки, содержащие EM

то есть нужно условие как то вставить "Cравнивать ячейку целиком", в екселе есть такое,
но как запрограммировать ту-ту =)

american17@mail.ru

Чтобы макрос работал и для объединённых ячеек, используйте такой вариант кода:

Sub УдалениеСтрокСОбъединённымиЯчейками()
    Application.ScreenUpdating = False    ' отключаем обновление экрана
    On Error Resume Next    ' отключаем остановку при ошибке

    ТекстДляПоиска = "Наименование ценности"    ' удаляем строки с таким текстом

    Do ' повторяем, пока есть ячейки с заданным текстом
        ActiveSheet.UsedRange.Find(ТекстДляПоиска, , xlValues, xlPart).MergeArea.EntireRow.Delete
    Loop Until Err ' если возникла ошибка (ячейка не найдена) - останавливаемся
End Sub

Этот вариант немного медленнее, чем предложенный в статье, но объединённые ячейки для него не страшны.

Добрый день. Использовала ваш код и решила свою проблему. Только вот загвоздка.
Это все работает если информация содержится в не объединенных ячейках.
Например в моем случае : Нужно сначала снять объединение ячеек, потом скопировать туда информацию, чтобы была в двух строках а потом уже эти строки удалить?

пока получилось только так Range("C25").Select
Selection.AutoFill Destination:=Range("C25:C26"), Type:=xlFillDefault
Range("C25:C26").Select
но это через макрос.

Странно, но даже при Вашем варианте, приведенном выше в посте №6, ВБА выдает ошибку №91, пишет Object variable or With block variable not set. Как Вы думаете, в чем может быть причина ошибки? Про свой вариант перебирания конкретно заданных листов "Лист1" и "Лист2" по заданным диапазонам (как я предполагал в посте №8) и подавно не работает.

Чтобы задать область поиска на листе "Лист1" в строке с 5-й по 200-ю (как у Вас в примере) я так понимаю, должен изменить строку
For Each ra In Intersect(sh.UsedRange, sh.Range("5:200")).Rows

на

For Each ra In Intersect(sh.UsedRange, sh.Range("Лист1!5:Лист1!200")).Rows

Правильно я рассуждаю? Спасибо за помощь!

Спасибо за ответ, теперь попытаюсь прикрутить подобного вида диапазоны отдельно для каждого листа, а то они у меня не совпадают, и поэтому пока удаляется нужная информация.

Или можно в данном контексте конкретно прописать область поиска?

Конечно можно.

В этой строке определяется диапазон для поиска:
For Each ra In sh.UsedRange.Rows
UsedRange - это ВЕСЬ ИСПОЛЬЗУЕМЫЙ диапазон листа.

Вы же можете задать определённый диапазон ячеек, например, так:
(оставьте одну из этих строк)

      For Each ra In Intersect(sh.UsedRange, sh.Range("a14:d1000")).Rows ' диапазон ячеек a14:d1000
       For Each ra In Intersect(sh.UsedRange, sh.Range("b4:h48,g55:n99")).Rows ' диапазоны ячеек b4:h48, g55:n99
       For Each ra In Intersect(sh.UsedRange, sh.Range("b:e,h:i")).Rows ' столбцы b:e и h:i
       For Each ra In Intersect(sh.UsedRange, sh.Range("5:200")).Rows ' строки с 5-й по 200-ю

Огромное спасибо. Сам бы вряд ли додумался! Еще раз спасибо!
А как в данном случае обозначить условие "пустая ячейка" заданная как финансовая (в плане отображения данных в ней)? А то я в условия поиска "0" ставлю, так у меня половина реквизитов скрывается. Или можно в данном контексте конкретно прописать область поиска?

Спасибо.

Чтобы макрос обрабатывал ВСЕ листы в книге, используйте такой вариант кода:

Sub УдалениеСтрокПоНесколькимУсловиям()
    Dim ra As Range, delra As Range, sh As Worksheet
    Application.ScreenUpdating = False    ' отключаем обновление экрана

    ' ищем и удаляем строки, содержащие заданный текст
    ' (можно указать сколько угодно значений, и использовать подстановочные знаки)
    УдалятьСтрокиСТекстом = Array("Наименование *", "Количество", _
                                  "текст?", "цен*сти", "*78*")
 
    ' перебираем все листы в активной книге
    For Each sh In ActiveWorkbook.Worksheets
        ' очистка переменной при переходе к следующему листу
        Set delra = Nothing
 
        ' перебираем все строки в используемом диапазоне очередного листа
        For Each ra In sh.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 ra
 
        ' если подходящие строки найдены, то: (оставьте одну из 2 следующих строк)
        If Not delra Is Nothing Then delra.EntireRow.Hidden = True    ' скрываем их
        If Not delra Is Nothing Then delra.EntireRow.Delete    ' удаляем их

    Next sh    ' переходим к следующему листу
End Sub

Спасибо за Ваш макрос. Самый подходящий под мои нужны. Единственное НО. Этот макрос работает только для активного листа, а как сделать так, чтобы он и нажатии кнопки с "Лист1" выполнял то же самое еще и на "Лист2" и "Лист3" одновременно? Подскажите, пожалуйста, как грамотно изменить синтаксис?

Исправил.
Впрочем, объявлять переменные не требуется, если не включена соответствующая опция в настройках редактора VBA.
Я такую опцию не включаю - поэтому и без объявления переменной код работает.

Переменную ТекстДляПоиска забыли объявить

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.