Kod çok yavaş çalışıyor

[k0081]

Merhaba arkadaşlar;

aşağıda vermiş olduğum kod dosya adındaki karakterleri Değiştirmeye yarıyor...

Fakat çok yavaş çalışıyor.. Ekleme yapılacak başka fonksiyon mu var acaba ?

yardımcı Arkadaşa şimdiden teşekkürler..

Private Sub CommandButton1_Click()
Dim Eski_Karakter(), Yeni_Karakter()
Dim Dosya As String, Zaman As Date, X As Byte, veri As String
Zaman = Time

Eski_karakter01 = InputBox(" " & _
"" & Chr(13) & _
"Yol:  " & CurDir & Chr(13) & _
"" & Chr(13) & _
"Eski Karakteri Giriniz :", "Dosya adı değiştir")
If Eski_karakter01 = "" Then
MsgBox "İşlem iptal edildi."
End
Exit Sub
End If

Yeni_Karakter01 = InputBox(" " & _
"" & Chr(13) & _
"Yol:  " & CurDir & Chr(13) & _
"" & Chr(13) & _
"Eski karakter : " & Eski_karakter01 & Chr(13) & _
"" & Chr(13) & _
"Yeni Karakteri Giriniz :", "Dosya adı değiştir")
If Yeni_Karakter01 = "" Then
MsgBox "İşlem iptal edildi."
End
Exit Sub
End If

Eski_Karakter = Array(Eski_karakter01)
Yeni_Karakter = Array(Yeni_Karakter01)

Dosya = Dir(CurDir & "\*.*")

While Dosya <> ""
        veri = Dosya
        DoEvents
        For X = 0 To UBound(Eski_Karakter)
        veri = Replace(veri, Eski_Karakter(X), Yeni_Karakter(X))
        Next
Name CurDir & "\" & Dosya As CurDir & "\" & veri
Dosya = Dir
Wend
MsgBox "Dosya adı işleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Time - Zaman, "hh:mm:ss"), vbInformation
End
End If
End Sub