Excel VBA：Sheet2条目未在Sheet1匹配时跳过行删除操作

• 存在两个Excel工作表：Sheet1为导入的XML格式阶梯结构表格，共数千行数据；Sheet2为单列字符串列表，包含数百条待匹配条目
• 核心需求：查找Sheet2中每个精确字符串在Sheet1内的所有匹配项，删除匹配项所在的Sheet1整行；方案需通用可复用，适配后续两个工作表数据源的持续增长、变动
• 此前方案问题：曾尝试编写Python脚本基于Sheet2内容裁剪XML源，但生成的XML文件损坏、存在数据类型丢失问题，无法正常使用；需要确认Excel处理路径可保留原有数据类型
• 数据规模：Sheet1约20000行、200列，Sheet2约400行单列数据；因数据安全要求无法提供原始数据，可基于模拟数据集调试

将工作表视为通过[行,列]索引的数组，目标逻辑如下：

String str;
Int r, foundStrRow;

// rowFind(sheet, string)：在指定工作表内查找目标字符串，返回匹配行索引
// Delete(sheet, row)：从指定工作表中删除指定索引的整行
while(Sheet2[r,1]) {
   str = Sheet2[r, 1];
   foundStrRow = rowFind(Sheet1,str);
   Delete(Sheet1, foundStrRow);
   r++
}

• 已编写的基础VBA代码可实现字符串匹配成功时删除Sheet1对应整行的功能，但缺少匹配结果判断逻辑：当Sheet2中的字符串未在Sheet1中找到匹配项时，代码会直接运行报错，需要补充未找到匹配时自动跳过、继续处理下一条的逻辑
• 原代码逐行删除、依赖选中单元格操作，处理2万行规模数据时效率极低，且仅能删除第一个匹配项，无法处理同一字符串在Sheet1中多次出现的场景

现有未完成代码如下：

Sub Trimmer()
Dim Rows2 as Integer
Dim wordToSearch as String

'Sets Rows2 to be limit of the loop
With Sheet2
    With .Cells.SpecialCells(xlCellTypeLastCell)
        Rows2 = .Row
    End With
End With

For r2=1 to Rows2
    Sheets("Sheet2").Select
    wordToSearch = Cells(r2,1).Value
    Sheets("Sheet1").Select
    Cells.Find(What := wordToSearch, After := ActiveCell, LookIn := xlFormulas2, _
      LookAt :=xlWhole, SearchOrder := xlByRows, SearchDirection:= xlNext, _
      MatchCase := False, SearchFormat := False).Activate
    Rows(ActiveCell.Row).Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp

修复点说明：

• 移除所有不必要的Select/Activate选中操作，避免选中状态导致的逻辑偏差
• 新增Find结果判空逻辑，未找到匹配项时直接跳过当前条目，不会触发运行错误
• 新增全表循环匹配逻辑，同一字符串在Sheet1中多次出现时，所有匹配行都会被处理
• 采用收集待删除行后一次性批量删除的逻辑，相比逐行删除效率提升数十倍，适配2万行级别的大文件
• 处理时匹配单元格显示值（xlValues），可保留导入XML的原有数据类型，不会出现格式丢失问题
• 处理过程中临时关闭屏幕更新、事件触发，进一步提升运行速度，处理完成后自动恢复默认设置

完整可直接运行的代码：

Sub Trimmer()
    Dim lastRowS2 As Long, r2 As Long
    Dim wordToSearch As String
    Dim findResult As Range
    Dim delRows As Range
    Dim firstAddr As String
    
    ' 临时关闭Excel非必要功能提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 动态获取Sheet2最后一行行号，适配后续数据增长
    With ThisWorkbook.Worksheets("Sheet2")
        lastRowS2 = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    
    ' 遍历Sheet2所有待匹配字符串
    For r2 = 1 To lastRowS2
        wordToSearch = Trim(ThisWorkbook.Worksheets("Sheet2").Cells(r2, 1).Value)
        ' 空条目直接跳过
        If wordToSearch <> "" Then
            Set delRows = Nothing
            With ThisWorkbook.Worksheets("Sheet1")
                ' 执行精确匹配查找
                Set findResult = .Cells.Find( _
                    What:=wordToSearch, _
                    After:=.Cells(1, 1), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False, _
                    SearchFormat:=False)
                
                ' 找到匹配项时收集所有对应行，未找到则直接跳过
                If Not findResult Is Nothing Then
                    firstAddr = findResult.Address
                    Do
                        ' 合并待删除行范围
                        If delRows Is Nothing Then
                            Set delRows = findResult.EntireRow
                        Else
                            Set delRows = Union(delRows, findResult.EntireRow)
                        End If
                        Set findResult = .Cells.FindNext(findResult)
                    ' 循环直到回到第一个匹配项位置，避免重复处理
                    Loop While Not findResult Is Nothing And findResult.Address <> firstAddr
                    
                    ' 一次性删除所有匹配行
                    delRows.Delete Shift:=xlUp
                End If
            End With
        End If
    Next r2
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "数据处理完成！"
End Sub

注意事项：

1. 运行代码前请备份原始文件，避免误删数据无法恢复
2. 如果需要匹配单元格公式而非显示值，可将代码中LookIn:=xlValues修改为LookIn:=xlFormulas2
3. 代码使用ThisWorkbook限定工作表所属工作簿，避免多开Excel时出现工作表定位错误

内容的提问来源于stack exchange，提问作者Kawaii Leonard