EXCEL VBA代码搜索单元格以匹配列表，如果不匹配则删除

Question

（此示例的图片链接如下）：数据从“A11”行开始，一个数据块是 A11 到 A14，我需要搜索该范围以查看它是否包含工作表 2 列表中的成员名称，例如 Erik Christensen，如果工作表 2 上的列表没有该名称，我需要删除 A11 到 A14 行并继续下一个块。表 2 上的列表将有不同数量的成员需要检查，因此需要考虑在内。处理完所有行后，我需要将它们重新排序以从 A11 行开始。请看图片，我将非常感谢您的帮助。

Sheet 1

Answer 1

对于下面的答案，我做了一些假设：

1. 您的数据将始终从第一个工作表的第 11 行开始 工作簿。
2. 搜索词总是在第二行，下面 对象：...
3. 数据将始终以 4 行的形式出现，如图所示， 结尾：在第 4 行。
4. 有效名称列表位于 工作簿中的第二张工作表。
5. “重新排序以从 A11 行开始”，我假设您的意思是 剩余的数据块应该从 A11 行开始并继续到 数据的结尾，而不是任何实际的排序（即按名称） 必填。

此代码将遍历所有数据块（从最后一个开始，因为我们正在删除行）。如果第二张表的 A 列中的任何名称出现在数据块中，则跳过该块。否则，如果没有出现名称，则删除该块。

Sub SearchAndDeleteList()

Dim i As Long
Dim j As Long
Dim LRow As Long
Dim LListRow As Long
Dim BMatch As Boolean

'Find last instance of "End:" in
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row
'Find last non-blank row in column A of second sheet
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False

If LRow >= 11 Then
    'Make sure there are at least 11 rows of data
    i = LRow
    'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line
    Do
        BMatch = False
        For j = 1 To LListRow
            'Test this block to see if the value from j appears in the second row of data
            If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then
                BMatch = True
                Exit For
            End If
        Next j
        'Application.StatusBar = "Match status for row " & i & ": " & BMatch
        If Not BMatch Then
            'Loop backwards to find the starting row (no lower than 11)
            For j = i To 11 Step -1
                If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For
            Next j
            Sheets(1).Rows(j & ":" & i).Delete
            i = j - 1
        Else
            'Find next block
            If i > 11 Then
                For j = i - 1 To 11 Step -1
                    If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For
                Next j
                i = j
            Else
                i = 10 'Force the loop to exit
            End If
        End If
        'Application.StatusBar = "Moving to row " & i
    Loop Until i < 11

    'Loop back through and delete any blank rows
    LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
    'MsgBox "Second checkpoint: new last row of data is " & LRow
    For i = LRow To 11 Step -1
        If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete
    Next i
End If

'Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 2

感谢 Nick 破解 OP 的实际需求，我特此提出一个解决方案，该解决方案应该根据 Op 的未来需求更易于维护和/或更改

Option Explicit

Sub SearchAndDeleteList2()

Dim dataSht As Worksheet
Dim dataRng As Range, namesRng As Range, cell As Range, rangeToDelete As Range
Dim firstAddress As String


'------------------------------
' setting stuff - begin
Set dataSht = ThisWorkbook.Sheets("Sheet1Data") '<== change 'data' sheet as per your needs
With dataSht
    Set dataRng = .Range("A11:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
If dataRng.Rows(1).row < 11 Then Exit Sub

With ThisWorkbook.Sheets("Sheet2Names") '<== change 'names' sheet as per your needs
    Set namesRng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With

Call ApplicationSet(False, False, xlCalculationManual, False)
' setting stuff - end
'------------------------------


'------------------------------
' core code - begin
Set cell = dataRng.Find("End:", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cell Is Nothing Then
    firstAddress = cell.Address
    Do
        If Not MyMatch(GetName(cell.Offset(-2)), namesRng) Then Call UpdateRngToDelete(rangeToDelete, dataSht.Rows(cell.row).Offset(-3).Resize(4))

        Set cell = dataRng.FindNext(cell)
    Loop While cell.Address <> firstAddress

    rangeToDelete.Delete
End If
' core code - end
'------------------------------


Call ApplicationSet(True, True, xlCalculationAutomatic, True)

End Sub


Function GetName(cell As Range) As String
Dim iIni As Integer
Dim iEnd As Integer

iIni = InStr(cell.value, """") '<== the 'name' is always preceeded by '"' character
iEnd = InStr(cell.value, "\")  '<== the 'name' is always follwed by '/' character

GetName = Mid(cell.value, iIni + 1, iEnd - iIni - 1)

End Function


Sub UpdateRngToDelete(baseRng As Range, toBeAddedRng As Range)

If baseRng Is Nothing Then
    Set baseRng = toBeAddedRng
Else
    Set baseRng = Union(baseRng, toBeAddedRng)
End If

End Sub


Function MyMatch(value As String, rng As Range) As Boolean

MyMatch = Not IsError(Application.Match(value, rng, 0))

End Function

使用单独的函数或子函数可以更轻松（更快！）保持控制和调试未来的代码更改