TransliterateForURL - Транслитерация для URL

Макрос транслитерации выделенного диапазона с кириллицы на латиницу (из русских буковок получаются буржуйские) с адаптацией результата для использования в составе URL.

Да, я люблю изобретать велосипеды, но в данном случае моя любовь к бесполезным изобретениям тут ни при чём.

Знаю, что макросы подобные представленному здесь в изобилии представлены на просторах интернета и успешно используются многими пользователями, мной в частности. Не было цели придумать что-то принципиально новое, важно было получить свою легальную копию продукта, с немного специфичным уклоном, который можно распространять на своё усмотрение, не нарушая авторства.

Второй важной задачей было опробовать возможности ChatGPT в сфере написания скриптов для Экселя. Нейросеть со своей задачей прекрасно справилась, хоть и не с первого раза. После многократных корректировок я получил ровно то, что было нужно.

В-третьих, требовалась понятная инструкция к макросу, которую также любезно составил ChatGPT. 😊 Сам то я разберусь (точнее вспомню) как макросы к Экселю прилаживать, а вот для коллег нужна инструкция.

Ну и четвёртое: поскольку в VBA я мало что понимаю, то для меня важно, что каждый блок кода снабжен комментарием, поясняющим функции блока. Таким образом проще внести незначительные коррективы, если потребуется, даже не обладая глубокими познаниями в сфере.

Код макроса:

Sub TransliterateForURL()
    Dim cell As Range
    Dim cyrillicToLatin As Object
    Set cyrillicToLatin = CreateObject("Scripting.Dictionary")
    
    ' Задаем пары кириллических символов и их латинских эквивалентов
    cyrillicToLatin.Add "А", "A": cyrillicToLatin.Add "Б", "B": cyrillicToLatin.Add "В", "V"
    cyrillicToLatin.Add "Г", "G": cyrillicToLatin.Add "Д", "D": cyrillicToLatin.Add "Е", "E"
    cyrillicToLatin.Add "Ё", "E": cyrillicToLatin.Add "Ж", "ZH": cyrillicToLatin.Add "З", "Z"
    cyrillicToLatin.Add "И", "I": cyrillicToLatin.Add "Й", "I": cyrillicToLatin.Add "К", "K"
    cyrillicToLatin.Add "Л", "L": cyrillicToLatin.Add "М", "M": cyrillicToLatin.Add "Н", "N"
    cyrillicToLatin.Add "О", "O": cyrillicToLatin.Add "П", "P": cyrillicToLatin.Add "Р", "R"
    cyrillicToLatin.Add "С", "S": cyrillicToLatin.Add "Т", "T": cyrillicToLatin.Add "У", "U"
    cyrillicToLatin.Add "Ф", "F": cyrillicToLatin.Add "Х", "H": cyrillicToLatin.Add "Ц", "TS"
    cyrillicToLatin.Add "Ч", "CH": cyrillicToLatin.Add "Ш", "SH": cyrillicToLatin.Add "Щ", "SCH"
    cyrillicToLatin.Add "Ъ", "": cyrillicToLatin.Add "Ы", "Y": cyrillicToLatin.Add "Ь", ""
    cyrillicToLatin.Add "Э", "E": cyrillicToLatin.Add "Ю", "YU": cyrillicToLatin.Add "Я", "YA"
    
    ' Пары для строчных букв
    cyrillicToLatin.Add "а", "a": cyrillicToLatin.Add "б", "b": cyrillicToLatin.Add "в", "v"
    cyrillicToLatin.Add "г", "g": cyrillicToLatin.Add "д", "d": cyrillicToLatin.Add "е", "e"
    cyrillicToLatin.Add "ё", "e": cyrillicToLatin.Add "ж", "zh": cyrillicToLatin.Add "з", "z"
    cyrillicToLatin.Add "и", "i": cyrillicToLatin.Add "й", "i": cyrillicToLatin.Add "к", "k"
    cyrillicToLatin.Add "л", "l": cyrillicToLatin.Add "м", "m": cyrillicToLatin.Add "н", "n"
    cyrillicToLatin.Add "о", "o": cyrillicToLatin.Add "п", "p": cyrillicToLatin.Add "р", "r"
    cyrillicToLatin.Add "с", "s": cyrillicToLatin.Add "т", "t": cyrillicToLatin.Add "у", "u"
    cyrillicToLatin.Add "ф", "f": cyrillicToLatin.Add "х", "h": cyrillicToLatin.Add "ц", "ts"
    cyrillicToLatin.Add "ч", "ch": cyrillicToLatin.Add "ш", "sh": cyrillicToLatin.Add "щ", "sch"
    cyrillicToLatin.Add "ъ", "": cyrillicToLatin.Add "ы", "y": cyrillicToLatin.Add "ь", ""
    cyrillicToLatin.Add "э", "e": cyrillicToLatin.Add "ю", "yu": cyrillicToLatin.Add "я", "ya"
    
    ' Проходим по каждой ячейке в выделенном диапазоне
    For Each cell In Selection
        If Not IsEmpty(cell.Value) Then
            Dim text As String
            text = cell.Value
            Dim transliteratedText As String
            transliteratedText = ""
            
            ' Выполняем транслитерацию по символам
            For i = 1 To Len(text)
                Dim char As String
                char = Mid(text, i, 1)
                
                ' Проверяем, есть ли символ в словаре
                If cyrillicToLatin.exists(char) Then
                    transliteratedText = transliteratedText & cyrillicToLatin(char)
                Else
                    ' Заменяем пробелы на дефисы и добавляем только допустимые символы, включая дефисы
                    If char = " " Then
                        transliteratedText = transliteratedText & "-"
                    ElseIf char Like "[A-Za-z0-9-]" Then
                        transliteratedText = transliteratedText & char
                    ' Блок кода для сохранения подчёркиваний
                    ElseIf char = "_" Then
                        transliteratedText = transliteratedText & "_"  ' <<<<< Легко закомментировать эту строку
                    End If
                End If
            Next i
            
            ' Преобразуем в нижний регистр
            transliteratedText = LCase(transliteratedText)
            
            ' Убираем возможные повторяющиеся дефисы
            Do While InStr(transliteratedText, "--") > 0
                transliteratedText = Replace(transliteratedText, "--", "-")
            Loop
            
            ' Удаляем дефис в начале и конце строки, если он есть
            If Left(transliteratedText, 1) = "-" Then transliteratedText = Mid(transliteratedText, 2)
            If Right(transliteratedText, 1) = "-" Then transliteratedText = Left(transliteratedText, Len(transliteratedText) - 1)
            
            ' Устанавливаем результат в ячейку
            cell.Value = transliteratedText
        End If
    Next cell
End Sub