Excel VBA查找命名区域文本并匹配设置对应字体颜色

• 包含2个工作表：Report 和 Leaving
• 定义1个命名区域Leavers：位于Leaving工作表A列，为人员全名列表，其中部分名称字体为红色，其余为橙色。

编写VBA宏，在Report工作表的G列至M列范围内，查找所有属于Leavers命名区域的名称，为每个匹配到的单元格应用与Leavers区域内源名称完全一致的字体颜色。

当前编写的代码仅支持通过输入框逐个输入名称搜索，效率和手动按Ctrl+F逐个查找无明显差异，暂未找到更优实现逻辑，需要更高效的替代方案、优化代码及解决思路。
现有代码如下：

Dim Sh As Worksheet
Dim Found As Range
Dim Nme As String
Dim Adr1 As String
 
Nme = Application.InputBox("Enter Name to search", "Test")
 
Set Sh = Sheets("Sheet1")
 
With Sh.Range("A2:A")
 
   Set Found = .Find(What:=Nme, After:=.Range("A2"), _
       LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlNext, _
       MatchCase:=False, SearchFormat:=False)
    If Not Found Is Nothing Then
        Adr1 = Found.Address
    Else
       MsgBox "Name could not be found"
       Exit Sub
    End If
    Do
       Found.Interior.ColorIndex = 4
       Set Found = .FindNext(Found)
    Loop Until Found Is Nothing Or Found.Address = Adr1
End With
End Sub

核心思路 #

• 直接读取已定义的Leavers命名区域所有条目，全程无需手动输入名称，一次性完成全量匹配
• 遍历Leavers区域时同步记录每个名称对应的字体颜色，无需硬编码颜色值，后续调整源颜色也能自动适配
• 限定查找范围为Report表G列到M列，使用全字匹配规则避免短名称误匹配
• 运行时临时关闭屏幕更新，大幅降低大文件场景下的运行耗时

可直接使用的优化代码 #

Sub SyncLeaversFontColor()
    Dim wsReport As Worksheet
    Dim leaversRange As Range, searchRange As Range
    Dim foundCell As Range, leaverCell As Range
    Dim firstMatchAddr As String
    
    ' 临时关闭屏幕更新提升运行效率
    Application.ScreenUpdating = False
    
    ' 绑定相关对象
    Set wsReport = ThisWorkbook.Worksheets("Report")
    Set leaversRange = ThisWorkbook.Names("Leavers").RefersToRange
    Set searchRange = wsReport.Columns("G:M")
    
    ' 可选：清空目标区域原有字体颜色，不需要可注释该行
    searchRange.Font.ColorIndex = xlColorIndexAutomatic
    
    ' 遍历所有离职人员条目
    For Each leaverCell In leaversRange
        ' 跳过空单元格避免无效查找
        If VBA.Trim(leaverCell.Value) <> "" Then
            ' 在目标范围执行全字匹配查找
            Set foundCell = searchRange.Find( _
                What:=leaverCell.Value, _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                MatchCase:=False _
            )
            
            ' 找到匹配项则循环处理所有同值单元格
            If Not foundCell Is Nothing Then
                firstMatchAddr = foundCell.Address
                Do
                    ' 直接同步源单元格的字体颜色
                    foundCell.Font.Color = leaverCell.Font.Color
                    Set foundCell = searchRange.FindNext(foundCell)
                Loop While Not foundCell Is Nothing And foundCell.Address <> firstMatchAddr
            End If
        End If
    Next leaverCell
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "处理完成，已同步所有匹配人员名称的字体颜色", vbInformation
End Sub

代码说明 #

• 运行宏后自动完成全量匹配，不需要任何手动输入，处理效率远高于逐次查找的方案
• 采用全字匹配规则，不会出现类似“张三”匹配到“张三丰”的误判问题
• 颜色完全同步Leavers区域的源格式，无论源名称是红色、橙色还是后续修改为其他颜色，都不需要调整代码
• 自动跳过Leavers区域的空单元格，避免无效查找拖慢速度

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