Excel VBA需求：按列标题匹配列表更新对应单元格标记

需求回顾 #

Sheet1结构：A列(App ID)、B列(状态)、C列(可换行的备注)，表头行已添加Sheet2的A列标记名称；Sheet2结构：A列(标记名称)、B列(需匹配的备注文本片段)。需要实现：匹配备注中的片段后，在Sheet1对应标记名称的列写入1。

修改后的代码 #

Sub UpdateTagsByRemark()
    Dim w1 As Worksheet, w2 As Worksheet
    Dim tagCol As Long, lastRowW1 As Long, lastRowW2 As Long
    Dim c As Range, foundCell As Range, firstFoundAddr As String
    
    Application.ScreenUpdating = False
    
    ' 定义工作表
    Set w1 = ThisWorkbook.Worksheets("Sheet1")
    Set w2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 获取Sheet2的有效数据行数
    lastRowW2 = w2.Cells(w2.Rows.Count, "B").End(xlUp).Row
    
    ' 遍历Sheet2的每条匹配规则
    For Each c In w2.Range("B2:B" & lastRowW2)
        ' 获取当前规则对应的标记名称
        Dim tagName As String
        tagName = w2.Cells(c.Row, "A").Value
        
        ' 在Sheet1表头（第1行）找标记名称对应的列号
        On Error Resume Next
        tagCol = Application.Match(tagName, w1.Rows(1), 0)
        On Error GoTo 0
        
        ' 如果找到对应列，开始匹配备注
        If tagCol > 0 Then
            ' 查找Sheet1备注列中包含当前片段的单元格
            Set foundCell = w1.Columns("C").Find(What:=c.Value, LookIn:=xlFormulas, _
                LookAt:=xlPart, MatchCase:=False, SearchFormat:=False)
            
            If Not foundCell Is Nothing Then
                firstFoundAddr = foundCell.Address
                ' 循环标记所有匹配的行
                Do
                    w1.Cells(foundCell.Row, tagCol).Value = 1
                    Set foundCell = w1.Columns("C").FindNext(foundCell)
                Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddr
            End If
        End If
    Next c
    
    Application.ScreenUpdating = True
End Sub

关键修改说明 #

1. 动态获取标记列：用Application.Match在Sheet1第1行查找标记名称，得到对应列号，替代原代码固定的E列
2. 匹配所有符合条件的行：新增FindNext循环，避免只标记第一个匹配的单元格
3. 错误处理：添加On Error语句处理标记名称不存在的情况，防止代码报错中断
4. 优化性能：提前获取工作表的最后有效行，减少不必要的范围遍历

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