Option Explicit
Sub trnsp()
Dim s() As String
Dim n&
n = Len(Cells(1, 1))
ReDim s(0 To 0, 0 To n - 1)
Dim i&
For i = 1 To n Step 1
If i <> 1 And i <> n Then
s(0, i - 1) = Mid(Cells(1, 1), i, 1)
ElseIf i = 1 Then
s(0, i - 1) = Left(Cells(1, 1), 1)
ElseIf i = n Then
s(0, i - 1) = Right(Cells(1, 1), 1)
End If
Next i
Dim r As Range
Set r = Range(Cells(2, 2), Cells(n + 1, 2))
r.Value = Application.Transpose(s)
End Sub