Sub sdss()
Dim i As Long, n As Long
k = Len(Cells(2, 1))
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("B2:E" & lr + 1).ClearContents
For n = 2 To lr
For i = 1 To k
    x = Mid(Cells(n, 1), i, 1)
    If x Like "[а,и,с,ъ]" Then
        Z = 1
    ElseIf x Like "[б,й,т,ы]" Then
        Z = 2
    ElseIf x Like "[в,к,у,ь]" Then
        Z = 3
    ElseIf x Like "[г,л,ф,э]" Then
        Z = 4
    ElseIf x Like "[д,м,х,ю]" Then
        Z = 5
    ElseIf x Like "[е,н,ц,я]" Then
        Z = 6
    ElseIf x Like "[ё,о,ч]" Then
        Z = 7
    ElseIf x Like "[ж,п,ш]" Then
        Z = 8
    ElseIf x Like "[з,р,щ]" Then
        Z = 9
    Else
        Z = ""
    End If
    
    If x Like "[а,у,о,ы,и,э,я,ю,ё,е]" Then
        Cells(n, 2) = Cells(n, 2) & x
        Cells(n, 3) = Cells(n, 3) & Z
    ElseIf x Like "[б,в,г,д,ж,з,й,к,л,м,н,п,р,с,т,ф,х,ц,ч,ш,щ]" Then
        Cells(n, 4) = Cells(n, 4) & x
        Cells(n, 5) = Cells(n, 5) & Z
    End If
Next i
Next n
End Sub

=ОБЪЕДИНИТЬ("";1;ЕСЛИОШИБКА(ПРОСМОТР(ПСТР($A$2;СТРОКА(A1:A30);1);A21:A53;ЕСЛИ(C21:C53;B21:B53;""));""))