Страницы: 1
RSS
Дополнить макрос преобразования из кириллицы в латиницу
 
Добрый день!
Есть код, который через формулу производит транслитерацию из кириллицы в латиницу, так же там казахские символы с ними тоже была проблема, в коде они определяются как знаки вопросов, поэтому запилил ссылкой на ячейку А1.
Необходимо дописать условия:
1. Спереди добавлять латинскую "y" если буква "е" первая буква в слове либо после гласных букв "а", "у", "о", "и", "я", "е", "ә", "і", "ү ","ө", "ъ"
примеры:Елена - Yelena; Каратаев - Karatayev; Сергеев - Sergeyev
2. Если буква "й" не первая или последняя буква в слове, то заменяется на латинскую "i"
пример: Айдар - Aidar
3. Если буква "й" первая или последняя бука в слове, то заменяется на латинскую "y"
примеры: Андрей - Andrey; Дмитрий - Dmitriy
4. Если буква "с" распложена между двумя гласными буквами  ("у", "о", "ы", "э", "ю", "ё", "а", "и", "я", "е", "ә", "і", "ү ","ө ", "ұ"), то заменяется на латинские "ss"
пример: Әсел - Assel; Нурасыл - Nurassyl
 
Shquall, здравствуйте!
Цитата
Shquall: казахские символы с ними тоже была проблема, в коде они определяются как знаки вопросов
просто используйте функции Chr() и/или ChrW(), которые возвращают символ по его числовому индексу
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, приветствую! Спасибо за подсказку!

Если оставить этот макрос и уже на полученую латиницу накидать второй макрос.
1. Спереди добавлять латинскую "y" если теперь уже после первого макроса латинская буква "e" первая буква в слове либо после гласных уже латинских букв "a", "u", "o", "i", "y", "e"
примеры: Elena - Yelena; Karataev - Karatayev; Sergeev - Sergeyev
2. Если уже латинская буква "y" не первая или последняя буква в слове, то заменяется на латинскую "i"
пример: Aydar - Aidar
3 пункт отпадает
4. Если уже латинская буква "s" распложена между двумя уже латинских буквами "a", "u", "o", "i", "y", "e", то заменяется на латинские "ss"
пример: Asel - Assel; Nurasyl - Nurassyl
Думаю так будет проще, надеюсь понятно рассписал))

Заранее спасибо!
 
Проверяйте. Функция должна работать с любыми кодовыми страницами Windows и с любыми региональными настройками.
Код
Option Explicit
Function KzCyrToLat(ByVal s As String) As String
    Static cyr, lat, Dict As Object
    Dim i As Long, s1 As String, s2 As String, arr() As String, b As Boolean, n As Long
    If IsEmpty(cyr) Then
        ' буквы казахского алфавита
        cyr = Array(1072, 1073, 1074, 1075, 1076, 1077, 1105, 1078, 1079, 1080, 1081, 1082, 1083, 1084, 1085, 1086, 1087, 1088, 1089, 1090, 1091, 1092, 1093, 1094, 1095, 1096, 1097, 1098, 1099, 1100, 1101, 1102, 1103, 1241, 1110, 1187, 1171, 1199, 1201, 1179, 1257, 1211)
        lat = Array("a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "y", "k", _
            "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
            "sh", "sch", "", "y", "", "e", "yu", "ya", "a", "i", "ng", "g", "u", "u", "k", "o", "h")
        If UBound(cyr) <> UBound(lat) Then
            MsgBox "Dimensions of arrays cyr and lat must be the same", vbCritical
            Exit Function
        End If
    
        Set Dict = CreateObject("Scripting.Dictionary")
        For i = 0 To UBound(cyr)
            Dict(ChrW(cyr(i))) = lat(i)
            Dict(UCase(ChrW(cyr(i)))) = StrConv(lat(i), vbProperCase)
        Next i
    End If  ' первоначального заполнения
        
    ReDim arr(1 To Len(s))
    For i = 1 To Len(s)
      s1 = Mid(s, i, 1)
      If Dict.exists(s1) Then
        arr(i) = Dict(s1)
      Else
        arr(i) = s1
      End If
    Next i
        
    ' Обработка "особых" правил
    n = UBound(arr)
    For i = 1 To n
      s1 = arr(i)
      If LCase(s1) = "e" Then  ' добавляем y к е
        If i = 1 Then
          b = True
        Else
          b = LCase(arr(i - 1)) Like "[aouiye]"
        End If
        If b Then arr(i) = IIf(s1 = "e", "ye", "Ye")
        
      ElseIf LCase(s1) = "y" And i > 1 And i < n Then
         arr(i) = IIf(arr(i) = "y", "i", "I")
        
      ElseIf LCase(s1) = "s" And i > 1 And i < n Then
        If LCase(arr(i - 1)) Like "[aouiye]" And LCase(arr(i + 1)) Like "[aouiye]" Then arr(i) = IIf(arr(i) = "s", "ss", "Ss")
      End If
    Next i

    KzCyrToLat = Join(arr, "")
End Function
Владимир
 
sokol92, Идеально! Спасибо большое, Владимир!
 
Shquall, не надо мне писать в личку - для решения проблемы у вас есть тема
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Shquall, Владимир, возможно ли добавить еще условие, если в исходном тексте уже латинские символы, то "особые условия" не применялись к ним?
Jack Famous, извиняюсь!
 
Версия 2.
Код
Function KzCyrToLat(ByVal s As String) As String
    Static cyr, lat, Dict As Object
    Dim i As Long, s1 As String, s2 As String, arr() As String, arr2() As Long, b As Boolean, n As Long
    If IsEmpty(cyr) Then
        ' буквы казахского алфавита
        cyr = Array(1072, 1073, 1074, 1075, 1076, 1077, 1105, 1078, 1079, 1080, 1081, 1082, 1083, 1084, 1085, 1086, 1087, 1088, 1089, 1090, 1091, 1092, 1093, 1094, 1095, 1096, 1097, 1098, 1099, 1100, 1101, 1102, 1103, 1241, 1110, 1187, 1171, 1199, 1201, 1179, 1257, 1211)
        lat = Array("a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "y", "k", _
            "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
            "sh", "sch", "", "y", "", "e", "yu", "ya", "a", "i", "ng", "g", "u", "u", "k", "o", "h")
        If UBound(cyr) <> UBound(lat) Then
            MsgBox "Dimensions of arrays cyr and lat must be the same", vbCritical
            Exit Function
        End If
     
        Set Dict = CreateObject("Scripting.Dictionary")
        For i = 0 To UBound(cyr)
            Dict(ChrW(cyr(i))) = lat(i)
            Dict(UCase(ChrW(cyr(i)))) = StrConv(lat(i), vbProperCase)
        Next i
    End If  ' первоначального заполнения
         
    n = Len(s)
    ReDim arr(1 To n)
    ReDim arr2(1 To n)
    
    For i = 1 To Len(s)
        s1 = Mid(s, i, 1)
        If Dict.exists(s1) Then
            arr(i) = Dict(s1)
            arr2(i) = 1  ' признак трансляции символов
        Else
            arr(i) = s1
        End If
    Next i
         
    ' Обработка "особых" правил
    For i = 1 To n
        If arr2(i) = 1 Then
            s1 = arr(i)
            If LCase(s1) = "e" Then  ' добавляем y к е
                If i = 1 Then
                    b = True
                Else
                    b = LCase(arr(i - 1)) Like "[aouiye]"
                End If
                If b Then arr(i) = IIf(s1 = "e", "ye", "Ye")
         
            ElseIf LCase(s1) = "y" And i > 1 And i < n Then
                arr(i) = IIf(arr(i) = "y", "i", "I")
         
            ElseIf LCase(s1) = "s" And i > 1 And i < n Then
                If LCase(arr(i - 1)) Like "[aouiye]" And LCase(arr(i + 1)) Like "[aouiye]" Then arr(i) = IIf(arr(i) = "s", "ss", "Ss")
            End If
        End If
    Next i
    KzCyrToLat = Join(arr, "")
End Function
Владимир
 
sokol92, И еще раз спасибо, Владимир!
 
sokol92, Владимир, еще хотел спросить, почему если я меняю в коде изменения не применяются?
например в коде там где перечисление на что менять "lat = Array(...." -  нужно чтобы "щ" изменилась не на "sch" а на "csh" я соответственно задаю, но замена происходит на sch
 
Функция заполняет массивы и словарь для перекодировки при первом выполнении. Если Вы меняете массив для перекодировки, то нажмите после этого кнопку сброса проекта "Reset" на инструментальной линейке (синий квадратик) или в главном меню Run/Reset.
Владимир
 
sokol92, приветствую, Владимир!
Заметил что на больших объёмах StrConv(lat(i), vbProperCase) стабильно проигрывает UCase() / UCase$(), также как и StrComp() проигрывает обычному сравнению через "=" (и нужно для других случаев)
Изменено: Jack Famous - 30.09.2020 12:00:05
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
sokol92, Ок, буду знать! Спасибо большое!
 
Здравствуйте, Алексей! Вполне возможно, но в #8 упомянутая Вами функция StrConv используется только при первом обращении, так что влияние на производительность это не оказывает. В циклах я пользуюсь испытанными Lcase/Ucase.
Владимир
 
Цитата
sokol92: используется только при первом обращении
так всё равно ж в цикле  :D
Так поприятнее:
Код
        For i = 0 To UBound(cyr)
            Dict(ChrW(cyr(i))) = lat(i)
            Dict(UCase(ChrW(cyr(i)))) = UCase(lat(i))
        Next i
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
sokol92, Jack Famous, Приветствую!
Еще нужны небольшие корректировки, если конечно это возможно. Условия в примере.
Заранее спасибо!
 
Проверяйте!
Владимир
 
sokol92, Офигенно, спасибо!
Что посоветуете почитать для развития в этом направлении?))
 
В части Excel и VBA - материалы данного сайта, сайта  Дмитрия Щербакова.

Успехов!
Владимир
Страницы: 1
Наверх