Транслитерация в Ворд по LanguageID

[Ивка]

Доброго времени суток!
Я не спец, поэтому лепил макрос на глазок.
Может ли кто-то из знатоков помочь понять, почему он не работает. Цель: поиск в выбранном куске текста (не во всем документе!) участков, набранных русской / украинской раскладкой, и их соответствующая транслитерация.
Спасибо при любом результате!

Sub Test()
'Identify Rus and Ukr and transliterate
Dim sLatRu As Variant
Dim sLatUa As Variant
Dim sRus As String
Dim sUkr As String
Dim sOutRu As String
Dim sOutUa As String
Dim ochRu As Range, indexRu As Long
Dim ochUa As Range, indexUa As Long

sRus = "абвгдеёжзийклмнопрстуфхцчшщъыьэюяА БВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ"
sLatRu = Array("a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "sch", "", "y", "", "e", "yu", "ya", "A", "B", "V", "G", "D", "E", "Yo", "Zh", "Z", "I", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Sch", "", "Y", "", "E", "Yu", "Ya")
sUkr = "абвгдежзіїєийклмнопрстуфхцчшщьюяАБ ВГДЕЖЗІЇЄИЙКЛМНОПРСТУФХЦЧШЩЬЮЯ"
sLatUa = Array("a", "b", "v", "g", "d", "e", "zh", "z", "i", "yi", "ye", "y", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "sch", "", "yu", "ya", "A", "B", "V", "G", "D", "E", "Zh", "Z", "I", "Yi", "Ye", "Y", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Sch", "", "Yu", "Ya")

If Selection.LanguageID = wdRussian Then
For Each ochRu In Selection.Characters
indexRu = InStr(1, sRus, ochRu.text, vbBinaryCompare)
If indexRu <> 0 Then
sOut = sOutRu & sLatRu(indexRu - 1)
Else
sOutRu = sOutRu & ochRu.text
End If
Next
End If
Selection.TypeText sOutRu

If Selection.LanguageID = wdUkrainian Then
For Each ochUa In Selection.Characters
indexUa = InStr(1, sUkr, ochUa.text, vbBinaryCompare)
If indexUa <> 0 Then
sOutUa = sOutUa & sLatUa(indexUa - 1)
Else
sOutUa = sOutUa & ochUa.text
End If
Next
End If
Selection.TypeText sOutUa
End Sub

[Вождь]

1. Лишний пробел между А и Б:

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

2. Здесь должно быть sOutRu, а не sOut:

sOut = sOutRu & sLatRu(indexRu - 1)

[Ивка]

Вождь, спасибо!
Сейчас исправлю и проверю.

[Ивка]

К сожалению, не работает! Пробел между А и Б появляется при вставке в окно вопроса. В оригинале пробел отсутствует.
Вот исправленный код

Sub Test()
Identify Ru and Ukr and transliterate
Dim sLatRu As Variant
Dim sLatUkr As Variant
Dim sRu As String
Dim sUkr As String
Dim sOutRu As String
Dim sOutUkr As String
Dim ochRu As Range, indexRu As Long
Dim ochUkr As Range, indexUkr As Long

sRu = "абвгдеёжзийклмнопрстуфхцчшщъыьэюяА БВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ"
sLatRu = Array("a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "sch", "", "y", "", "e", "yu", "ya", "A", "B", "V", "G", "D", "E", "Yo", "Zh", "Z", "I", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Sch", "", "Y", "", "E", "Yu", "Ya")
sUkr = "абвгдежзіїєийклмнопрстуфхцчшщьюяАБ ВГДЕЖЗІЇЄИЙКЛМНОПРСТУФХЦЧШЩЬЮЯ"
sLatUkr = Array("a", "b", "v", "g", "d", "e", "zh", "z", "i", "yi", "ye", "y", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "sch", "", "yu", "ya", "A", "B", "V", "G", "D", "E", "Zh", "Z", "I", "Yi", "Ye", "Y", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Sch", "", "Yu", "Ya")

If Selection.LanguageID = wdRussian Then
For Each ochRu In Selection.Characters
indexRu = InStr(1, sRus, ochRu.text, vbBinaryCompare)
If indexRu <> 0 Then
sOutRu = sOutRu & sLatRu(indexRu - 1)
Else
sOutRu = sOutRu & ochRu.text
End If
Next
End If
Selection.TypeText sOutRu

If Selection.LanguageID = wdUkrainian Then
For Each ochUkr In Selection.Characters
indexUkr = InStr(1, sUkr, ochUkr.text, vbBinaryCompare)
If indexUkr <> 0 Then
sOutUkr = sOutUkr & sLatUkr(indexUkr - 1)
Else
sOutUkr = sOutUkr & ochUkr.text
End If
Next
End If
Selection.TypeText sOutUkr
End Sub

[Ивка]

Не работает и базовый код (не работает, если выделенный тест вперемежку русско-украинский или выделение несплошное (островками)):

Sub Test()
'Identify Rus and transliterate
Dim sLat As Variant
Dim s As String
Dim sOut As String
Dim och As Range, index As Long

s = "абвгдеёжзийклмнопрстуфхцчшщъыьэюяА БВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ"
sLat = Array("a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "sch", "", "y", "", "e", "yu", "ya", "A", "B", "V", "G", "D", "E", "Yo", "Zh", "Z", "I", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Sch", "", "Y", "", "E", "Yu", "Ya")

'If Selection.LanguageID = wdRussian Then
For Each och In Selection.Characters
index = InStr(1, s, och.text, vbBinaryCompare)
If Selection.LanguageID = wdRussian And index <> 0 Then
sOut = sOut & sLat(index - 1)
Else
sOut = sOut & och.text
End If
Next
'End If
Selection.TypeText sOut
End Sub

[Вождь]

Прям крик души Думаю, нужно такое:

Option Explicit

Sub LangTrans()

    If IsObjectValid(Selection) <> True Then Exit Sub
    If Selection.Type <> wdSelectionNormal Then Exit Sub
    
Dim aRu As Variant, sRu As String
    sRu = "абвгдеёжзийклмнопрстуфхцчшщъыьэюяАБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ"
    aRu = Array("a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "sch", "", "y", "", "e", "yu", "ya", "A", "B", "V", "G", "D", "E", "Yo", "Zh", "Z", "I", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Sch", "", "Y", "", "E", "Yu", "Ya")
    
Dim aUkr As Variant, sUkr As String
    sUkr = "абвгдежзіїєийклмнопрстуфхцчшщьюяАБВГДЕЖЗІЇЄИЙКЛМНОПРСТУФХЦЧШЩЬЮЯ"
    aUkr = Array("a", "b", "v", "g", "d", "e", "zh", "z", "i", "yi", "ye", "y", "i", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "sch", "", "yu", "ya", "A", "B", "V", "G", "D", "E", "Zh", "Z", "I", "Yi", "Ye", "Y", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Sch", "", "Yu", "Ya")

Dim C As Range
Dim S As String, S2 As String
Dim i As Long, j As Long

    For Each C In Selection.Characters
        S2 = C.Text
        If C.LanguageID = wdRussian Then
            i = InStr(1, sRu, S2, vbBinaryCompare)
            If i > 0 Then
                S2 = aRu(i - 1)
                j = j + 1
            End If
         ElseIf C.LanguageID = wdUkrainian Then
            i = InStr(1, sUkr, S2, vbBinaryCompare)
            If i > 0 Then
                S2 = aUkr(i - 1)
                j = j + 1
            End If
         End If
         S = S & S2
    Next
    If j > 0 Then Selection.TypeText S
    
End Sub

[Ивка]

Вождь, снимаю перед Вами шляпу!
Спасибо огроменное!

PS.Просто творческое любопытство - как заставить код (и можно ли в принципе) работать на разбросанных по документу выделенных участках текста?
Но это, конечно, уж мёд ложкой с моей стороны.
Буду искать.

Еще раз спасибо-спасибо!