Sub BulkReplace()
  Dim Rng As Range, SourceRng As Range, ReplaceRng As Range
  
  Dim rCount As Long   '<New
  Dim tCount As Long '<New
  Dim aSheet As String '<New
  
  aSheet = ActiveSheet.Name
    
  On Error Resume Next
  Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
  Set SourceRng = Application.InputBox("Source data:", "Bulk Replace", Application.Selection.Address, Type:=8)
  Err.Clear
 
  If Not SourceRng Is Nothing Then
    Set ReplaceRng = Application.InputBox("Replace range:", "Bulk Replace", Type:=8)
    Err.Clear
    If Not ReplaceRng Is Nothing Then
      
      Application.ScreenUpdating = False
        
        Worksheets.Add.Name = "Progress"
        tCount = Worksheets(aSheet).Cells(Rows.Count, 1).End(xlUp).Row '<New
        
            Worksheets(aSheet).Activate
        
        For Each Rng In ReplaceRng.Columns(1).Cell
          
                SourceRng.Replace what:=Rng.Value, replacement:=Rng.Offset(0, 1).Value
                rCount = rCount + 1
               
                If Int(rCount) / rCount = 1 Then '<New
                    Application.ScreenUpdating = False '<New
                        Worksheets("Progress").Range("a1") = rCount & "/" & tCount '<New
                        Worksheets("Progress").Activate '<New
                    Application.ScreenUpdating = True '<New
                End If '<New
                
        Next
       End If
  End If
  Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub