Macro para realizar fácilmente reemplazos múltiples de texto o números

 Código:

Sub IBReemplazosMúltiples()

Dim R As Range, B As Range, S As Range, C As Range, x As Range, y As Range

On Error Resume Next

Set R = Application.InputBox("Selecciona el rango donde se realizará el reemplazo de palabras:", Type:=8)

On Error GoTo 0

If R Is Nothing Then Exit Sub

On Error Resume Next

Set B = Application.InputBox("Buscar:", Type:=8)

On Error GoTo 0

If B Is Nothing Then Exit Sub

On Error Resume Next

Set S = Application.InputBox("Reemplazar con:", Type:=8)

On Error GoTo 0

If S Is Nothing Then Exit Sub

If Not (B.Cells.Count = S.Cells.Count) Then

MsgBox "Los rangos de Buscar y Reemplazar con no tienen el mismo tamaño. Asegúrate de que ambos rangos tengan la misma cantidad de celdas."

Exit Sub

End If

Application.ScreenUpdating = False

For Each C In R

If C.HasFormula Then

For Each x In B

Set y = S.Cells(x.Row - B.Cells(1).Row + 1)

C.Formula = Replace(C.Formula, x.Value, y.Value, , , vbTextCompare)

Next x

Else

For Each x In B

Set y = S.Cells(x.Row - B.Cells(1).Row + 1)

Do While InStr(1, C.Value, x.Value, vbTextCompare) > 0

C.Value = Replace(C.Value, x.Value, y.Value, , , vbTextCompare)

Loop

Next x

End If

Next C

Application.ScreenUpdating = True

MsgBox "Reemplazo de palabras completado."

End Sub