Find and replace multiple values at once with VBA code

Question

I have this VBA code to find and replace multiple values at once,i need one more feature in the code if the value is not replaced in the cell and remains same, content in the cell has to deleted and print as NO CHANGE. Could you please help to fix this code.

Sheet 1

List
Apple
Mango
grapes
Banana

Sheet 2

List	Color
Apple	Red
Mango	yellow
grapes	black

Expected output

Sheet 1

List
Red
yellow
black
NO CHANGE

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

I tried to print the status but none worked

Answer 1

You can add another loop that checks for a non-empty cell then replace the text if so. Something like -

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

(I haven't tested this, but hopefully it gives you an idea on how to make it work.)