Транслитерация. Сохранение форматирования текста

Function Translit(ByVal txt As String) As String
   txtRussian = Array("", "щ", "ч", "ш", "ъ", "ы", "ь", "э", "ю", "я", "ё", "ж", "й", "а", "б", "в", "г", "д", "е", "з", "и", "к", _
    "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц")
    arrTranslit = Array("", "zch", "ch", "sh", "''", "'y", "'", "eh", "ju", "ja", "jo", "zh", "jj", "a", "b", "v", "g", "d", "e", "z", "i", "k", _
    "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "c")
 
    For iCount = 1 To 33
        txt = Replace(txt, txtRussian(iCount), arrTranslit(iCount), , , vbBinaryCompare)
        txt = Replace(txt, UCase(txtRussian(iCount)), UCase(arrTranslit(iCount)), , , vbBinaryCompare)
    Next
    ThisDocument.Range.InsertAfter (vbNewLine & txt)
    
    For iCount = 1 To 33
        txt = Replace(txt, arrTranslit(iCount), txtRussian(iCount), , , vbBinaryCompare)
        txt = Replace(txt, UCase(arrTranslit(iCount)), UCase(txtRussian(iCount)), , , vbBinaryCompare)
    Next
    ThisDocument.Range.InsertAfter (txt)
End Function
 
 
Sub Test_Translit()
    Dim r As Range
    Set r = ActiveDocument.Range
    
    Translit (r)
End Sub