Главная » Макросы для 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

  • 246838 просмотров

Комментарии

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

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".
Гость, 12 Сен 2011 - 19:29.#1

Относительно вопроса от 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

Гость, 9 Сен 2011 - 19:12.#2

Добрый день!
Вы знаете, пробовал и в одном месте убрать 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

NAS, 9 Сен 2011 - 14:54.#3

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

NAS, 9 Сен 2011 - 14:52.#4

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

Гость, 27 Авг 2011 - 10:46.#5

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

Игорь (администратор сайта), 24 Авг 2011 - 15:36.#6

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

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

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

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

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

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

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

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

и т.д. и т.п.

Гость, 24 Авг 2011 - 14:37.#7

Одной строчкой все условия у меня не влезают, 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

Гость, 21 Авг 2011 - 17:14.#8

Спасибо )

Игорь (администратор сайта), 21 Авг 2011 - 16:45.#9

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

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

Гость, 21 Авг 2011 - 16:34.#10

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

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

?

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

PainInYourBrain, 29 Июл 2011 - 07:05.#11

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 Оффиса.

Антон, 24 Июл 2011 - 19:45.#12

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

Игорь (администратор сайта), 24 Июл 2011 - 19:21.#13

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

 

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

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

Антон, 24 Июл 2011 - 15:39.#14

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

Гость, 4 Июл 2011 - 21:43.#15

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

Игорь (администратор сайта), 4 Июл 2011 - 11:24.#16

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

Юлия, 4 Июл 2011 - 11:05.#17

Добрый день у меня два вопроса:
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).

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

Игорь (администратор сайта), 3 Июл 2011 - 18:38.#18

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

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

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

KiraLucky, 3 Июл 2011 - 17:39.#19

Я придумал)

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

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

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

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

KiraLucky, 3 Июл 2011 - 17:30.#20

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

Добавлю ваш сайт в 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

Игорь (администратор сайта), 3 Июл 2011 - 17:15.#21

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

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

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

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

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

KiraLucky, 3 Июл 2011 - 17:11.#22

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

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

american17@mail.ru

KiraLucky, 3 Июл 2011 - 17:02.#23

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

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

пример:

AEM
EM
EMERSON
AMETEK

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

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

american17@mail.ru

Игорь (администратор сайта), 24 Июн 2011 - 08:41.#24

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

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

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

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

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

Юлия, 23 Июн 2011 - 17:20.#25

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

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

Ищущий, 7 Июн 2011 - 11:49.#26

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

Ищущий, 7 Июн 2011 - 11:22.#27

Чтобы задать область поиска на листе "Лист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

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

Ищущий, 7 Июн 2011 - 11:12.#28

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

Игорь (администратор сайта), 6 Июн 2011 - 12:13.#29

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

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

В этой строке определяется диапазон для поиска:
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-ю

Ищущий, 6 Июн 2011 - 11:46.#30

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

Спасибо.

Игорь (администратор сайта), 6 Июн 2011 - 10:35.#31

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

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

Ищущий, 6 Июн 2011 - 08:17.#32

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

Игорь (администратор сайта), 19 Мар 2011 - 22:44.#33

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

Гость, 19 Мар 2011 - 19:00.#34

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

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

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