Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Готовые решения

МЕНЮ САЙТА
  • 1
  • 2
  • 3

КАТЕГОРИИ РАЗДЕЛА

ОПРОСЫ
Какой версией Excel Вы пользуетесь?
Всего ответов: 35789
Главная » Готовые решения » VBA » Полезные приёмы

Удаление строк на листе по критерию
02.11.2013, 21:13
[ Файл-пример (244.3Kb) ]
в качестве критерия возьмем значение "Level 2" в первом столбце
'удалить строки, у которых в 1-м столбце значение не "Level 2"
Sub example_01_1()
Dim i As Long, r As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
 With .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
 Set r = .Find("Level 2", lookat:=xlWhole)
 If Not r Is Nothing Then .ColumnDifferences(r).EntireRow.Delete
 End With
End With
Application.ScreenUpdating = True
End Sub

Sub example_01_2()
Dim i&, r As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
 With .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
 .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
 Set r = .Find("Level 2", lookat:=xlWhole)
 If Not r Is Nothing Then .ColumnDifferences(r).EntireRow.Delete
 End With
End With
Application.ScreenUpdating = True
End Sub

Sub example_02_1()
Application.ScreenUpdating = False
With Sheets("Sheet1").Range("A1").CurrentRegion
 .Parent.AutoFilterMode = False
 .AutoFilter Field:=1, Criteria1:="<>Level 2"
 .Offset(1).EntireRow.Delete
 .AutoFilter
 .Parent.UsedRange
End With
Application.ScreenUpdating = True
End Sub

Sub example_02_2()
Application.ScreenUpdating = False
With Sheets("Sheet1").Range("A1").CurrentRegion
 .Parent.AutoFilterMode = False
 .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
 .AutoFilter Field:=1, Criteria1:="<>Level 2"
 .Offset(1).EntireRow.Delete
 .AutoFilter
 .Parent.UsedRange
End With
Application.ScreenUpdating = True
End Sub

Sub example_03()
On Error Resume Next
Application.ScreenUpdating = False
With Sheets("Sheet1").Range("A1").CurrentRegion
 .Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=IF(RC[-3]<>""Level 2"","""",1)"
 With .CurrentRegion
 .Sort Key1:=.Cells(1, .Columns.Count), Order1:=xlAscending, Header:=xlYes
 .Columns(.Columns.Count).Offset(1).SpecialCells(-4123, 2).EntireRow.Delete 'Specialcells 8192 limit and non contiguous range
 .Columns(.Columns.Count).ClearContents
 End With
End With: Application.ScreenUpdating = True
End Sub
'а теперь удаляем строки с "Level 2" в 1-м столбце
Sub example_04()
Dim i As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
 With .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row)
 .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
 i = WorksheetFunction.CountIf(.Columns(1), "Level 2")
 .Columns(1).Find("Level 2", lookat:=xlWhole).Resize(i).EntireRow.Delete
 End With
 .UsedRange
End With
Application.ScreenUpdating = True
End Sub

Sub example_05()
On Error Resume Next
Application.ScreenUpdating = False
With Sheets("Sheet1").Range("A1").CurrentRegion
 .Columns(1).Replace "Level 2", Empty
 .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
 .Columns(1).SpecialCells(4).EntireRow.Delete
 .Parent.UsedRange
End With
Application.ScreenUpdating = True
End Sub
'медленно удаляем строки с "Level 2" в 1-м столбце (до ~1000 строк)
Sub example_06()
Dim x, i As Long, rDel As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
 Set rDel = .Range("B1")
 x = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Value
 For i = 1 To UBound(x)
 If x(i, 1) = "Level 2" Then Set rDel = Union(rDel, .Cells(i, 1))
 Next i
 If rDel.Count > 1 Then Intersect(.Columns(1), rDel).EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub
'еще медленнее удаляем строки с "Level 2" в 1-м столбце (до ~200 строк)
Sub example_07()
Dim i As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
 For i = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
 If .Cells(i, 1) = "Level 2" Then .Cells(i, 1).EntireRow.Delete
 Next i
End With
Application.ScreenUpdating = True
End Sub
Sub example_08()
On Error Resume Next
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
 .Value = Evaluate("IF(" & .Address & "=""Level 2"",""""," & .Address & ")")
 .SpecialCells(4).EntireRow.Delete
End With
End Sub
Добавил: nilem |
Просмотров: 4712 | Рейтинг: 5.0/3
Всего комментариев: 3
+1   Спам
1    MCH   (05.11.2013 13:23)
   еще вариант:
Sub DeleteRows()
Dim i As Long, rng As Range
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = "Level 2" Then
If rng Is Nothing Then Set rng = Rows(i) Else Set rng = Union(rng, Rows(i))
End If
Next i
If Not rng Is Nothing Then rng.Delete
End Sub

0   Спам
2    igrtsk   (04.02.2014 14:53)
   Создал новый файл с настройками по умолчанию, переименовал набросал различных значений в таблицу, в т.ч. в 1-й столбец добавил несколько Level 2, странице присвоил имя Sheet1.

Запустил макрос example_01_1 в ознакомительных целях. Макрос не работает. Остановка на строчке
If Not r Is Nothing Then .ColumnDifferences®.EntireRow.Delete

Попробовал макрос example_01_2
Снова стоп, снова указывает на .ColumnDifferences®.EntireRow.Delete

Макрос example_02_1
Остановка на строке With Sheets("Sheet1").Range("A1").CurrentRegion

Возникает очевидный вопрос: почему?

0   Спам
3    nilem   (07.02.2014 09:00)
   Добавил файл-пример, в котором можно проверить все эти коды

Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!