Страницы: 1
RSS
Обратная транслитерация ( с англ на русский), Первым делом заменить сочетания букв.
 
Необходимо в экселе делать обратную транслитерацию. Макрос за основу взял этот http://www.planetaexcel.ru/techniques/7/32/ и поменял местами англ и рус буквы. Но есть известная проблема, с сочетаниями буквами sh, ch и так далее. Поэтому есть смысл в макросе сначала проверить сочетания букв, а потом по отдельности буквы. Я в макросах не силен, только изучаю. Вопрос : замена в тексте сначала сочетаний, а потом уже отдельных букв. Помогите поправить мой макрос. Спасибо!

Function Transliterr  (Txt As String) As String

  1. Dim Eng As Variant
  2. Eng = Array("shh", "aa", "yy", "kh", "ch", "sh", "ts", "ya", "yu", "jo", "zh", "SHH", "AA", "YY", "KH", "CH", "SH", "TS", "YA", "YU", _
  3. "JO", "ZH", "'", "a", "b", "v", "g", "d", "e", "z", "i", "j", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "'", "A", "B", "V", _
  4. "G", "D", "E", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F")

  5. Dim Rus As Variant
  6. Rus = Array("щ", "э", "ы", "х", "ч", "ш", "ц", "я", "ю", "ё", "ж", "Щ", "Э", "Ы", "Х", "Ч", "Ш", "Ц", "Я", "Ю", _
  7. "Ё", "Ж", "а", "б", "в", "г", "д", "е", "з", "и", "й", "к", "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", _
  8. "ь", "А", "Б", "В", "Г", "Д", "Е", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", "С", "Т", "У", "Ф")
  9. For i = 1 To Len(Txt)
  10. с = Mid(Txt, i, 1)

  11. flag = 0
  12. For J = 0 To 64
  13. If Eng(J) = с Then
  14. outchr = Rus(J)
  15. flag = 1
  16. Exit For
  17. End If
  18. Next J
  19. If flag Then outstr = outstr & outchr Else outstr = outstr & с
  20. Next i

  21.  Transliterr = outstr
  22. End Function
 
Код надо в теги обрамлять.Кнопка <...>
Код
Function Transliterr(Txt As String) As String

    Dim Eng As Variant
    Eng = Array("shh", "aa", "yy", "kh", "ch", "sh", "ts", "ya", "yu", "jo", "zh", "SHH", "AA", "YY", "KH", "CH", "SH", "TS", "YA", "YU", _
                "JO", "ZH", "a", "b", "v", "g", "d", "e", "z", "i", "j", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "'", "A", "B", "V", _
                "G", "D", "E", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F")

    Dim Rus As Variant
    Rus = Array("щ", "э", "ы", "х", "ч", "ш", "ц", "я", "ю", "ё", "ж", "Щ", "Э", "Ы", "Х", "Ч", "Ш", "Ц", "Я", "Ю", _
                "Ё", "Ж", "а", "б", "в", "г", "д", "е", "з", "и", "й", "к", "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", _
                "ь", "А", "Б", "В", "Г", "Д", "Е", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", "С", "Т", "У", "Ф")

        For j = 0 To UBound(Rus)
          Txt = Replace(Txt, Rus(j), Eng(j))
        Next j
    Transliterr = Txt
End Function
 
Интересно, но макрос стал работать наоборот. Русские на англ. А надо что бы англ на русский. Как исправить?
 
Цитата
olebedev90 написал:
Как исправить?
наверно так:
Код
Txt = Replace(Txt, Eng(j), Rus(j))
Не стреляйте в тапера - он играет как может.
 
Спасибо, все работает!
Страницы: 1
Наверх