Как удалить строки в Excel на основе критериев с помощью VBA?

#excel #vba

Вопрос:

В настоящее время я создаю макрос для форматирования таблицы данных, а также для удаления неприменимых строк данных. В частности, я хочу удалить строки, где столбец L = «ABC», а также удалить строки, где столбец AA <> «DEF».

До сих пор мне удавалось достичь первой цели, но не второй. Существующий код:

 Dim LastRow As Integer
Dim x, y, z As Integer
Dim StartRow, StopRow As Integer

For x = 0 To LastRow
    If (Range("L1").Offset(x, 0) = "ABC") Then
    Range("L1").Offset(x, 0).EntireRow.Delete
    x = x - 1

End If

Ответ №1:

Обычно гораздо быстрее использовать автофильтр, а не циклические диапазоны

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

В рабочий столбец помещается формула

=OR(L1="ABC",AA1<>"DEF") в строку 1 первого пустого столбца затем копируется вниз до истинного используемого диапазона. Затем все ИСТИННЫЕ записи быстро удаляются с помощью автофильтра

 Sub QuickKill()
    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Set rng1 = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious)
    Set rng2 = Cells.Find("*", , xlValues, , xlByRows, xlPrevious)
    Set rng3 = Range(Cells(rng2.Row, rng1.Column), Cells(1, rng1.Column))
    Application.ScreenUpdating = False
    Rows(1).Insert
    With rng3.Offset(-1, 1).Resize(rng3.Rows.Count   1, 1)
        .FormulaR1C1 = "=OR(RC12=""ABC"",RC27<>""DEF"")"
        .AutoFilter Field:=1, Criteria1:="TRUE"
        .EntireRow.Delete
        On Error Resume Next
        'in case all rows have been deleted
        .EntireColumn.Delete
        On Error GoTo 0
    End With
    Application.ScreenUpdating = True
End Sub

Ответ №2:

Использование цикла:

 Sub test()
    Dim x As Long, lastrow As Long
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    For x = lastrow To 1 Step -1
        If Cells(x, 12).Value = "ABC" or Cells(x, 27) <> "DEF" Then
            Rows(x).Delete
        End If
    Next x
End Sub

Использование автофильтра (возможно, быстрее):

 Sub test2()
    Range("a1").AutoFilter Field:=12, Criteria1:="ABC", Operator:=xlOr, _
                           Field:=28, Criteria1:="<>""DEF"""
    'exclude 1st row (titles)
    With Intersect(Range("a1").CurrentRegion, _
                   Range("2:60000")).SpecialCells(xlCellTypeVisible)
        .Rows.Delete
    End With
    ActiveSheet.ShowAllData
End Sub

1. Ой, слишком быстро (я должен, если я хочу ответить, прежде чем вы это сделаете :))

2. Если вы не хотите удалять первую строку (если у вас есть заголовок), измените For x = lastRow To 1 Step -1 на For x = lastRow To 2 Step -1

Ответ №3:

Ячейка с номером 12 — «L», а номер 27 — «AA»

 Dim x As Integer

x = 1

Do While x <= ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

    If (Cells(x, 12) = "ABC") Then
    ActiveSheet.Rows(x).Delete
    Else
        If (Cells(x, 27) <> "DEF") And (Cells(x, 27) <> "") Then
        ActiveSheet.Rows(x).Delete
        Else
        x = x   1
        End If
    End If

Loop

End Sub

Ответ №4:

 Sub test()

    Dim bUnion As Boolean
    Dim i As Long, lastrow As Long
    Dim r1 As Range
    Dim v1 As Variant

    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    v1 = ActiveSheet.Range(Cells(1, 12), Cells(lastrow, 27)).Value2
    bUnion = False

    For i = 1 To lastrow
        If v1(i, 1) = "ABC" Or v1(i, 16) <> "DEF" Then
            If bUnion Then
                Set r1 = Union(r1, Cells(i, 1))
            Else
                Set r1 = Cells(i, 1)
                bUnion = True
            End If
        End If
    Next i
    r1.EntireRow.Delete

End Sub