Переименование всех файлов в папке из латиницы в кириллицу, не затрагивая расширение файла

ArrayRus = Split("А б Б в В г Г д Д е Е ё Ё ж Ж з З и И й Й к К л Л м М н Н о О п П р Р с С т Т у У ф Ф х Х ц Ц ч Ч ш Ш щ Щ ь Ь ы Ы ъ Ъ э Э ю Ю я Я") 
ArrayEng = Split("A b B v V g G d D e E e E zh Zh z Z i I i I k K l L m M n N o O p P r R s S t T u U f F kh Kh ts Ts ch Ch sh Sh shch Shch ' ' y Y ' ' e E yu Yu ya Ya") 
 
Set FSO = CreateObject("Scripting.FileSystemObject") 
'устанавливаем папку с файлами для переименования 
Set Folder = FSO.GetFolder(".\") 
For Each File In Folder.Files 
Ext = FSO.GetExtensionName(File.Name) 
If LCase(Ext) = "docx" Then 
BaseName = FSO.GetBaseName(File.Name) 
NewName = "" 
For x = 1 To Len(BaseName) 
Simv = (Mid(BaseName, x, 1)) 
'найдем в массиве символ 
ii = 0 
For i = 0 To UBound(ArrayRus) - 1 
If Simv = ArrayRus(i) Then 
NewName = NewName + ArrayEng(i) 
ii = 1 
Exit For 
End If 
Next 
If ii = 0 Then 
NewName = NewName + Simv 
End If 
Next 
FSO.MoveFile File.Name, NewName & "." & Ext 
End If 
Next

For i = 0 To UBound(ArrayRus) - 1 
If Simv = ArrayRus(i) Then 
NewName = NewName + ArrayEng(i)

For i = 0 To UBound(ArrayEng) - 1 
If Simv = ArrayEng(i) Then 
NewName = NewName + ArrayRus(i)