Dim tr, tl
tr="а б в г д е ё  ж  з и й  к л м н о п р с т у ф х  ц ч  ш  щ   ъ  ы ь э  ю  я  А Б В Г Д Е Ё  Ж  З И Й  К Л М Н О П Р С Т У Ф Х  Ц Ч  Ш  Щ   Ъ  Ы Ь Э  Ю  Я  "
tl="аaбbвvгgдdеeёjoжzhзzиiйjjкkлlмmнnоoпpрrсsтtуuфfхkhцcчchшshщshhъ''ы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ХKhЦCЧChШShЩShhЪ''ЫYЬ'ЭEhЮJuЯJa"

'=============================================================================
' функция транслитерации строки по ГОСТ 7.79 2000
Function translit(ByVal sIncoming)
    Dim pos, findpos, sSymbol
    
    translit=""

    For pos = 1 To len(sIncoming) Step 1

        sSymbol=mid(sIncoming,pos,1)
        findpos=InStr(1, tr, sSymbol)
        If findpos=0 or sSymbol=" " Then
            ' ***** В транслитерации не нуждается
            translit=translit+sSymbol
        Else
            ' ***** Первый символ
            translit=translit+mid(tl,findpos+1,1)
            ' ***** Второй символ
            If mid(tr,findpos+2,1)=" " Then
                translit=translit+mid(tl,findpos+2,1)
                ' ***** Третий символ
                If mid(tr,findpos+3,1)=" " Then
                    translit=translit+mid(tl,findpos+3,1)
                End If
            End If
        End If
    Next
End Function