إزالة الهمزات والمسافات الزائدة واستبدال (ى) بـ (ي) واستبدال (ة) بـ (ه)

[أباالحسن]

السلام عليكم 
استخدم هذا الكود لإزالة الهمزات والمسافات الزائدة واستبدال (ى) بـ (ي) واستبدال (ة) بـ (ه)

Sub ReplaceChar()

On Error Resume Next

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


   
   'هذا الكود لإزالة المسافات الزائدة فى الأسماء

Sheets("Teachers Data").Select
Sheets("Teachers Data").[B6:B324].Select
For Each cell In Selection
cell.Value = Application.WorksheetFunction.Trim(cell.Value)


'هذا الكود لاستبدال الحروف

    Sheets("Teachers Data").Range("B6:B324").Replace "أ", "ا"
    Sheets("Teachers Data").Range("B6:B324").Replace "إ", "ا"
    Sheets("Teachers Data").Range("B6:B324").Replace "آ", "ا"
    '-----------------
    Sheets("Teachers Data").Range("B6:B324").Replace "ة", "ه"
    Sheets("Teachers Data").Range("B6:B324").Replace "ى", "ي"
    Next

Sheets("Teachers Data").[B5].Select

MsgBox "ـ تم ضبط الاسماء بأستبدال ( أ - إ - آ )  بـ ( ا ) ـ" & _
vbCrLf & "ـ استبدال (ة) بـ (ه) || استبدال (ى) بـ (ي) ـ" & _
vbCrLf & "وإزالة المسافات الزائدة", vbInformation
End Sub

----
وهو يعمل لكنه بطئ ،  فهل هناك كود أفضل من ذلك 
أو كيف يمكن التعديل عليه ليعمل بصورة أفضل