VBA代码无法重复匹配B、D列值添加删除线问题求助

问题根源 #

原代码只执行了一次Find方法，只会定位到第一个B列值为A.1.的单元格，后续符合「B列值为A.1.且D列值匹配」的行完全被忽略；同时没有循环遍历所有匹配项，导致重复提交表单时无法找到新的符合条件的行。

修正后的代码 #

Dim A1 As Integer
Dim sec1 As String

'''A.1.
If sec1x = True Then   '''表单上的复选框
    sec1 = "A.1."      '''B列中要匹配的值
    A1 = A1x.Text      '''要在D列中查找的值
    Dim lrow As Long
    Dim findWS As Worksheet
    Dim findRng As Range
    Dim foundCell As Range
    Dim firstFoundAddr As String '记录第一个匹配单元格的地址，用于终止循环
    
    Set findWS = ActiveSheet
    lrow = findWS.Cells(findWS.Rows.Count, "B").End(xlUp).Row
    Set findRng = findWS.Range("B3:B" & lrow)

    '首次查找B列匹配项
    Set foundCell = findRng.Find(what:=sec1, LookIn:=xlFormulas, MatchCase:=False, lookat:=xlWhole)
    
    If Not foundCell Is Nothing Then '如果找到第一个匹配项
        firstFoundAddr = foundCell.Address '记录初始地址
        Do
            '检查当前行D列（偏移2列）的值是否匹配A1
            If foundCell.Offset(0, 2).Value = A1 Then
                foundCell.EntireRow.Font.Strikethrough = True
            End If
            '查找下一个匹配项
            Set foundCell = findRng.FindNext(foundCell)
        Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddr '循环直到回到初始地址
    End If
End If

关键改动说明 #

• 新增firstFoundAddr变量记录第一个匹配单元格的地址，避免出现无限循环
• 使用Do...Loop循环配合FindNext方法，遍历所有B列值为sec1的单元格
• 每次循环中检查对应D列的值，匹配成功则为整行添加删除线
• 增加If Not foundCell Is Nothing判断，避免未找到匹配项时触发错误

内容的提问来源于stack exchange，提问作者Ryan Data Guy