一括置換　VBA

Option Explicit

Sub 一括置換()
On Error Resume Next
Application.ScreenUpdating = False
  Dim buf, Target, s1, s2
  Set Target = Application.InputBox("範囲は連続／不連続どちらでもOK", "文字列一括置換＞対象範囲を選択", Type:=8)
  If Target = "" Then: Exit Sub

  Set s1 = Application.InputBox("範囲は連続／不連続どちらでもOK", "文字列一括置換＞置換したい文字列群を選択", Type:=8)
  If s1 = "" Then: Exit Sub

  Set s2 = Application.InputBox("範囲は連続／不連続どちらでもOK", "文字列一括置換＞新しい文字列群を選択", Type:=8)
  If s1.Cells.Count <> s2.Cells.Count Then
    MsgBox "置換したい文字列群と新しい文字列群の数が一致しません。" & vbLf & _
            "処理を中断します。"
    Exit Sub
  End If

  Dim s1c, s2c, c, i
  ReDim s1c(UBound(s1.Value2))
  ReDim s2c(UBound(s2.Value2))
  i = 1
  For Each c In s1.Cells
    s1c(i) = c.Value
    i = i + 1
  Next
  i = 1
  For Each c In s2.Cells
    s2c(i) = c.Value
    i = i + 1
  Next

  Dim r As Range ', i As Long
  For Each r In Target.Cells
    For i = 1 To UBound(s1.Value2)
      r.Value = Replace(r.Value, s1c(i), s2c(i))
    Next
  Next
  Application.ScreenUpdating = True
End Sub