Public Function TextAlpha2Code(Source As String, _
    Optional Encoding As Byte = 0, _
    Optional Prefix As String = "%") As String
' Заменяет символы невходящие в список допустимых их шеснадцатиричным кодом вида %XX
Const c_strProcedure = "TextAlpha2Code"
' Source    - кодируемая строка
' Encoding  - (не используется) тип кодировки 0-cp1251, 1-UTF-8, 2-URL код (как в поисковых запросах)
' Prefix   - префикс кода символа: "%","\u","=" или др
'    Encoding = 0        ' cp1251
Dim Result As String
    Result = vbNullString
    On Error GoTo HandleError
Dim c As Long, cMax As Long, cLen As Byte: c = 1: cMax = Len(Source): If cMax = 0 Then GoTo HandleExit
' определяем параметры кодирования
    Select Case Encoding
    Case 0: cLen = 2  ' cp1251   Prefix = "%"
    Case 1: cLen = 4  ' UTF-8    Prefix = "\u"
    Case 2: cLen = 2  ' URL код  Prefix = "%" или "="
    Case Else: Err.Raise vbObjectError + 512
    End Select
' задаем дополнительные разрешенные символы помимо a-z,A-Z и 0-9. можно вынести в параметр функции
Dim PermissedSymb As String: PermissedSymb = Replace(VBA.UCase$(c_strOthers), " ", "") '(c_strSymbRusAll & c_strOthers)  '(c_strOthers)
' пробегаем все символы строки
Dim Char As String, Code As String
    Do Until c > cMax
        Char = VBA.Mid$(Source, c, 1)
        Select Case Char
        Case "A" To "Z", "a" To "z", "0" To "9"
        Case Else: If InStr(1, PermissedSymb, VBA.UCase$(Char)) > 0 Then GoTo HandleNext
            Select Case Encoding
            Case 0: Code = VBA.Hex$(Asc(Char)):  Char = Prefix & String(cLen - Len(Code), "0") & Code
            Case 1: Code = VBA.Hex$(AscW(Char)): Char = Prefix & String(cLen - Len(Code), "0") & Code
            Case 2: Code = VBA.Hex$(AscW(Char)): Code = String(2 * cLen - Len(Code), "0") & Code
                    Select Case VBA.Left$(Code, cLen)
                    Case "00": Char = Prefix & VBA.Mid$(Code, cLen + 1)
                    Case "04": Char = Prefix & Hex$(&HD0 + (CLng(c_strHexPref & VBA.Mid$(Code, cLen + 1)) \ &H40)) & Prefix & Hex$(&H80 + (CLng(c_strHexPref & VBA.Mid$(Code, cLen + 1)) Mod &H40))
                    Case Else: Char = Prefix & VBA.Left$(Code, cLen) & Prefix & VBA.Mid$(Code, cLen + 1)
                    End Select
            End Select
        End Select
HandleNext:
        Result = Result & Char
        c = c + 1
    Loop
HandleExit:
    TextAlpha2Code = Result
    Exit Function
HandleError:
    Result = vbNullString
    Err.Clear: Resume HandleExit
End Function

Public Function TextCode2Alpha(Source As String, _
    Optional Encoding As Byte = 0, _
    Optional Prefix As String = "%") As String
' Заменяет код вида %XX, символов не входящих в список допустимых, их значением
Const c_strProcedure = "TextCode2Alpha"
' Source   - декодируемая строка
' Encoding - тип кодировки 0-cp1251, 1-UTF-8, 2-URL код (как в поисковых запросах)
' Prefix   - префикс кода символа: "%","\u","=" или др
Dim Result As String
    On Error GoTo HandleError
    Result = vbNullString
    On Error GoTo HandleError
Dim c As Long, cMax As Long, cLen As Byte: c = 1: cMax = Len(Source): If cMax = 0 Then GoTo HandleExit
' определяем параметры кодирования
    Select Case Encoding
    Case 0: cLen = 2  ' cp1251   Prefix = "%"
    Case 1: cLen = 4  ' UTF-8    Prefix = "\u"
    Case 2: cLen = 2  ' URL код  Prefix = "%" или "="
    Case Else: Err.Raise vbObjectError + 512
    End Select
' пробегаем все символы строки
Dim Char As String, Code As String, Cod2 As String
    Do Until c > cMax
        If VBA.Mid$(Source, c, Len(Prefix)) <> Prefix Then
' разрешенный (незакодированный) символ
            Char = VBA.Mid$(Source, c, 1)
        Else
' если находим управляющий символ - расшифровываем код
            Code = VBA.UCase$(VBA.Mid$(Source, c + Len(Prefix), cLen))
            Select Case Encoding
            Case 0: Code = c_strHexPref & Code: If IsNumeric(Code) Then Char = VBA.Chr$(Val(Code)):  c = c + cLen + Len(Prefix) - 1
            Case 1: Code = c_strHexPref & Code: If IsNumeric(Code) Then Char = VBA.ChrW$(Val(Code)): c = c + cLen + Len(Prefix) - 1
            Case 2: Code = c_strHexPref & Code: c = c + cLen + Len(Prefix) - 1
            ' символы U+0000..U+00FF >> %00..я
            ' символы U+0400..U+04FF >> РЂ..Рї;СЂ..Сї;ТЂ..Тї;УЂ..Уї
                    If IsNumeric(Code) Then
                        Select Case CLng(Code)
                        Case &HD0 To &HD3:
                            If VBA.Mid$(Source, c + 1, Len(Prefix)) = Prefix Then
                                Cod2 = c_strHexPref & VBA.UCase$(VBA.Mid$(Source, c + Len(Prefix) + 1, cLen))
                                If IsNumeric(Cod2) Then
                                    Select Case CLng(Cod2)
                                    Case &H80 To &HBF: Code = c_strHexPref & Hex(Val(&H400 + &H40 * (Val(Code) Mod &HD0) + Val(Cod2) - &H80)): c = c + cLen + Len(Prefix) '- 1
                                    Case Else:         Code = Code & Mid$(Cod2, Len(Prefix) + 1)
                                    End Select
                                End If
                            End If
                        Case Else:
                        End Select
                    End If
                    Char = VBA.ChrW$(Val(Code))  ' прочие символы
            End Select
        End If
HandleNextStep:
        Result = Result & Char
        c = c + 1
    Loop
HandleExit:
    TextCode2Alpha = Result
    Exit Function
HandleError:
    Result = vbNullString
    Err.Clear: Resume HandleExit
End Function