请求修改批量查找替换VBA代码：未替换单元格设为NO CHANGE

需求说明 #

现有一段实现批量查找替换的VBA代码，需新增功能：若单元格内容未被替换、保持原样，则将其内容清空并设置为“NO CHANGE”。

数据示例 #

Sheet1 原始数据 #

Sheet2 匹配数据 #

Sheet1 预期输出 #

原VBA代码 #

Sub MultiFindNReplace()
'Updateby Extendoffice
Dim Rng As Range
Dim InputRng As Range, ReplaceRng As Range
xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Original Range ", xTitleId, InputRng.Address, Type:=8)
Set ReplaceRng = Application.InputBox("Replace Range :", xTitleId, Type:=8)
Application.ScreenUpdating = False
For Each Rng In ReplaceRng.Columns(1).Cells
    InputRng.Replace what:=Rng.Value, replacement:=Rng.Offset(0, 1).Value
Next
Application.ScreenUpdating = True
End Sub

修改后的VBA代码 #

Sub MultiFindNReplaceWithNoChange()
Dim InputRng As Range, ReplaceRng As Range
Dim replaceDict As Object
Dim cell As Range, rng As Range
xTitleId = "KutoolsforExcel"

' 选择输入区域和替换区域
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Original Range ", xTitleId, InputRng.Address, Type:=8)
Set ReplaceRng = Application.InputBox("Replace Range :", xTitleId, Type:=8)

' 创建字典存储替换规则
Set replaceDict = CreateObject("Scripting.Dictionary")
For Each rng In ReplaceRng.Columns(1).Cells
    If Not replaceDict.Exists(rng.Value) And rng.Value <> "" Then
        replaceDict.Add rng.Value, rng.Offset(0, 1).Value
    End If
Next

Application.ScreenUpdating = False
' 遍历输入区域每个单元格，执行替换或标记
For Each cell In InputRng
    If replaceDict.Exists(cell.Value) Then
        cell.Value = replaceDict(cell.Value)
    Else
        cell.Value = "NO CHANGE"
    End If
Next
Application.ScreenUpdating = True
End Sub

代码修改说明 #

• 新增字典对象存储替换映射，大幅提升查找匹配效率，避免重复遍历替换区域
• 遍历输入区域的每个单元格，逐一判断是否存在对应的替换规则：
  • 匹配到规则则替换为目标值
  • 未匹配到规则直接设置为“NO CHANGE”
• 保留原有的区域选择交互逻辑，使用习惯不变
• 增加空值判断，避免替换区域的空单元格干扰字典存储

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