Function Translit$(iValue$)
iRussian$ = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя"
iTranslit = Array("", "A", "B", "V", "G", "D", "E", "Jo", "Zh", "Z", "I", "Jj", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "H", "C", "Ch", "Sh", "Zch", "''", "'Y", "'", "Eh", "Ju", "Ja", "a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "jj", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "c", "ch", "sh", "zch", "''", "'y", "'", "eh", "ju", "ja")

For iCount% =  1  To  65 
iValue$ = Replace(iValue$, Mid(iRussian$, iCount%,  1 ), iTranslit(iCount%), , , vbTextCompare) 'MS Excel 2000
Next
Translit$ = iValue$
End Function


Sub IspTranslit()
For Each cell In Selection
cell.Value = Translit(cell.Value)
Next
End Sub

Option Explicit

Function Translit$(iValue$)
Dim iRussian$, iCount%, iTranslit As Variant

    iRussian$ = "АБВГДЕЄЖЗИІЇЙКЛМНОПРСТУФХЦЧШЩЬЮЯабвгдеєжзиіїйклмнопрстуфхцчшщьюя"

    iTranslit = Array("", "A", "B", "V", "G", "D", "E", "Je", "Zh", "Z", "Y", "I", "I'", "J", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "H", "C", "Ch", "Sh", "Shh", "'", "Ju", "Ja", "a", "b", "v", "g", "d", "e", "je", "zh", "z", "y", "i", "i'", "j", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "c", "ch", "sh", "shh", "'", "ju", "ja")
    
    For iCount% =  1  To  65 
        iValue$ = Replace(iValue$, Mid(iRussian$, iCount%,  1 ), iTranslit(iCount%), , , vbBinaryCompare)  'MS Excel 2000
    Next
    Translit$ = iValue$
End Function

Sub IspTranslit()
Dim rCell As Range
    For Each rCell In Selection
        rCell.Value = Translit(rCell.Value)
    Next
End Sub