Option Explicit

Dim s As String
Dim CryptoKey As Integer, ns As Integer

Sub CreateCharTable()
    ' Заполняет строку с таблицей для шифрования/дешифрования
    Dim i As Integer, k As Integer
    Dim c As String
    i = 1
    s = ""
    c = "~"
    With Sheets("Лист1")
        While Len(c) > 0
            c = .Cells(i, 1).Value
            If Len(c) > 0 Then
                i = i + 1
                s = s + c
            End If
        Wend
    End With
End Sub

Function GetCodeChar(c As String) As String
    Dim i As Integer, j As Integer
    i = InStr(s, c)
    j = i + CryptoKey
    If j > ns Then j = j - ns
    GetCodeChar = Mid(s, j, 1)
End Function

Function GetDeCodeChar(c As String) As String
    Dim i As Integer, j As Integer
    i = InStr(s, c)
    j = i - CryptoKey
    If j <= 0 Then j = ns + j
    GetDeCodeChar = Mid(s, j, 1)
End Function

Sub CodeString(st)
    Dim i As Integer
    For i = 1 To Len(st)
        Mid(st, i, 1) = GetCodeChar(Mid(st, i, 1))
    Next i
End Sub

Sub Decodestring(st)
    Dim i As Integer
    For i = 1 To Len(st)
        Mid(st, i, 1) = GetDeCodeChar(Mid(st, i, 1))
    Next i
End Sub

Sub aaa()
    Dim c As String
    CryptoKey = Sheets("Лист1").Cells(2, 2).Value  'Ключ шифрования в (B2)
    CreateCharTable
    ns = Len(s)
    If CryptoKey >= ns Then
        MsgBox "Уменьшите длину ключа!"
    Else
        c = InputBox("Введите сообщение, первый символ Ш-щифровать, Д-дешифровывать")
        If Len(c) > 0 Then
            Select Case UCase(Left(c, 1))
            Case "Ш"
                c = Mid(c, 2)
                CodeString c
            Case "Д"
                c = Mid(c, 2)
                Decodestring c
            End Select
            MsgBox c
           
        End If
    End If
End Sub