使用 VBA 代码一次查找和替换多个值

Question

我有这个 VBA 代码可以一次查找和替换多个值，如果单元格中的值没有被替换并且保持不变，我需要代码中的另一个功能，单元格中的内容必须删除并打印为 NO CHANGE。 你能帮忙修复这段代码吗？

第 1 张

列表
苹果
芒果
葡萄
香蕉

工作表 2

列表	颜色
苹果	红色的
芒果	黄色的
葡萄	黑色的

预期产出

第 1 张

列表
红色的
黄色的
黑色的
没变化

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

我试图打印状态但没有成功

Answer 1

您可以添加另一个循环来检查非空单元格，如果是，则替换文本。 就像是 -

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

' New: Loop over remaining values and overwrite cells
For Each Rng in InputRng.Columns(1).Cells
  If IsEmpty(Rng.value) = false Then
    Rng.value = "NO CHANGE"
  End If
Next

Application.ScreenUpdating = True
End Sub

（我还没有测试过这个，但希望它能给你一个关于如何让它工作的想法。）