Question

我在另一条帖子中找到了此代码，该代码将选择一行-但是它将删除除指定行之外的所有其他代码。

我处理大量的地址列表，我需要运行一些可以识别和删除地址的行，这些行被要求不要邮寄到该地址。我刚刚发现VBA有点绿色。但是我想有一个模块，允许我随着列表的增加添加多个地址。

Sub DeleteRows()

   Dim i as long, LastRow As long
   with activesheet
       LastRow = .Cells(.Rows.Count, 1).End(xlUp).row

       For i =  LastRow to 2 step -1

           If .Cells(i, 1).Value <> "certain value" Then

              .Rows(i).Delete

           End If

       Next i
   End With
End Sub

Answer 1

只需更改一下：

If .Cells(i, 1).Value <> "certain value" Then-单元格值不同于“确定值”

对此：

If .Cells(i, 1).Value = "certain value" Then-单元格值等于“某些值”

Sub DeleteRows()

    Dim i As Long, LastRow As Long

    With ActiveSheet
        LastRow = .Cells(.Rows.count, 1).End(xlUp).row

        For i = LastRow To 2 Step -1
            If .Cells(i, 1).value = "certain value" Then
                .Rows(i).Delete
            End If
        Next i
    End With

End Sub

Answer 2

您可以使用Union一次性收集合格行并删除。另外，在单独的工作表中存储要匹配的地址。将这些地址读取到数组中，然后循环到要从中删除数据的工作表，并检查是否在数组中找到了给定的地址。如果找到，请使用联合存储该单元以供以后删除。在循环检查数据结束时，一次性删除与并集范围对象中存储的单元格关联的行。

Option Explicit
Public Sub DeleteThemRows()
    Dim arr(), unionRng As Range, i As Long, lastRow As Long, rng As Range
    Dim wsAddress As Worksheet, wsDelete As Worksheet

    Set wsAddress = ThisWorkbook.Worksheets("Addresses")
    Set wsDelete = ThisWorkbook.Worksheets("DataToDelete")

    With wsAddress                               '<= Assume addresses stored in column A starting from cell A1
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Select Case lastRow
        Case 1
            ReDim arr(1, 1): arr(1, 1) = .Range("A1").Value
        Case Is >= 2
            arr = .Range("A1:A" & lastRow).Value
        End Select
        arr = Application.WorksheetFunction.Index(arr, 0, 1)
    End With

    With wsDelete  '<==Assume address column to check is column A

        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Dim loopRange As Range
        Set loopRange = .Range("A1:A" & lastRow)
        If Application.WorksheetFunction.CountA(loopRange) = 0 Then Exit Sub

        For Each rng In loopRange.SpecialCells(xlCellTypeConstants)
            If Not IsError(Application.Match(rng.Value, arr, 0)) Then
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(unionRng, rng)
                Else
                    Set unionRng = rng
                End If
            End If
        Next
    End With
    If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
End Sub

您可以先使用Debug.Print unionRng.Address来检查要删除的内容。

使用VBA删除具有特定条件的行

3 个答案: