Sub Main()
    Dim Key As String
    Dim Msg As String
    Dim EncryptMsg As String
    Dim DecryptMsg As String

    Key = "мечта"
    Msg = "реализация шифра методом вертикальной перестановки с ключом мечта"

    EncryptMsg = VerticalShuffleEncrypt(Key, Msg)
    DecryptMsg = VerticalShuffleDecrypt(Key, EncryptMsg)

    Cells(1, 1).Value = Msg
    Cells(2, 1).Value = EncryptMsg
    Cells(3, 1).Value = DecryptMsg
End Sub

Function VerticalShuffleEncrypt(ByVal Key As String, ByVal Msg As String) As String
    Dim KeyArr As Object
    Dim L As Long
    Dim Col As String
    Dim Res As String

    L = Len(Msg)  Len(Key)
    If (Len(Msg) Mod Len(Key) <> 0) Then
        L = L + 1
    End If

    Set KeyArr = CreateObject("System.Collections.ArrayList")

    For I = 1 To Len(Key)
        KeyArr.Add Mid(Key, I, 1)
    Next I

    KeyArr.Sort

    Res = ""
    For Each K In KeyArr
        I = InStr(1, Key, K, vbTextCompare)
        Col = ""
        'For J = I To Len(Msg) Step L
        '    Res = Res & Mid(Msg, J, 1)
        'Next J
        For J = I To Len(Msg) Step Len(Key)
            Col = Col & Mid(Msg, J, 1)
        Next J
        If (Len(Col) <> L) Then
            Col = Col & " "
        End If
        Res = Res & Col
    Next

    VerticalShuffleEncrypt = Res
End Function

Function VerticalShuffleDecrypt(ByVal Key As String, ByVal Msg As String) As String
    Dim KeyArr As Object
    Dim IndexArr As Object
    Dim L As Long
    Dim Res As String

    L = Len(Msg)  Len(Key)
    If (Len(Msg) Mod Len(Key) <> 0) Then
        L = L + 1
    End If

    Set KeyArr = CreateObject("System.Collections.ArrayList")
    Set IndexArr = CreateObject("System.Collections.ArrayList")

    For I = 1 To Len(Key)
        KeyArr.Add Mid(Key, I, 1)
    Next I

    KeyArr.Sort

    For I = 1 To Len(Key)
        IndexArr.Add KeyArr.IndexOf(Mid(Key, I, 1), 0) + 1
    Next I

    Res = ""
    For I = 1 To L
        For Each Index In IndexArr
            Res = Res & Mid(Msg, ((Index - 1) * L) + I, 1)
        Next
    Next I

    VerticalShuffleDecrypt = Res
End Function

м   е   ч   т   а

3   2   5   4   1

р   е   а   л   и
з   а   ц   и   я
    ш   и   ф   р
а       м   е   т
о   д   о   м
в   е   р   т   и
к   а   л   ь   н
о   й       п   е
р   е   с   т   а
н   о   в   к   и
    с       к   л
ю   ч   о   м
м   е   ч   т   а