Sub каждую_букву_в_отдельную_ячейку()

Dim sl, Answer As String, i As Long

' уведомление для пользователя:
Answer = MsgBox("Для преобразования текста " & vbCrLf & _
"НУЖНЫЙ ТЕКСТ ДОЛЖЕН БЫТЬ ВЫДЕЛЕН" & vbCrLf & _
"(мышкой или стрелочками при нажатой клавише Shift)." & vbCrLf & vbCrLf & _
"Для подтверждения запуска макроса нажмите кнопку " & Chr$(34) & "ОК" & Chr$(34) _
, vbOKCancel + vbInformation, "Запущен макрос " & Chr$(34) & "Каждую букву - в отдельную ячейку" & Chr$(34))
If Answer = vbCancel Then Exit Sub

' отключить перерисовку (обновление) экрана после каждого выполненного действия:
Application.ScreenUpdating = False

' копировать выделенное:
Selection.Copy

' создать новый документ альбомной ориентации с полями по 1 см, верхнее 2 см:
Documents.Add DocumentType:=wdNewBlankDocument
WordBasic.PageSetupMargins Tab:=0, PaperSize:=0, TopMargin:="2", _
BottomMargin:="1", LeftMargin:="1", RightMargin:="1", Gutter:="0", _
PageWidth:="29.7", PageHeight:="21", Orientation:=1, FirstPage:=0, _
OtherPages:=0, VertAlign:=0, ApplyPropsTo:=4, FacingPages:=0, _
HeaderDistance:="1.25", FooterDistance:="1.25", SectionStart:=2, _
OddAndEvenPages:=0, DifferentFirstPage:=0, Endnotes:=0, LineNum:=0, _
CountBy:=0, TwoOnOne:=0, GutterPosition:=0, LayoutMode:=0, DocFontName:= _
"", FirstPageOnLeft:=0, SectionType:=1, FolioPrint:=0, ReverseFolio:=0, _
FolioPages:=1

'переход в начало документа (первую ячейку первой строки таблицы):
Selection.StartOf Unit:=wdStory, Extend:=wdMove

' вставить с сохранением форматирования:
Selection.PasteAndFormat (wdPasteDefault)

' выделить весь текст
Selection.WholeStory
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

' формат текста (шрифт, размер, жирный, курсив, регистр):
Selection.Font.Name = "Courier New"
Selection.Font.Size = 18
Selection.Font.Bold = False
Selection.Font.Italic = False
Selection.Range.Case = wdUpperCase

'== вставка сепараторов после каждого символа по всему тексту ====================================
sl = Len(Selection.Text)
Selection.MoveLeft

For i = 1 To sl
Selection.MoveRight Unit:=wdCharacter, Count:=1
If Selection.Text = " " Then
Selection.Text = Replace(Selection.Text, Selection.Text, "°" & vbCrLf)
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeBackspace
i = i + 1
Else
Selection.TypeText Text:="°"
End If
Next
'===========================================================================================

'переход в начало документа (первую ячейку первой строки таблицы):
Selection.StartOf Unit:=wdStory, Extend:=wdMove

' выделить весь текст
Selection.WholeStory
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

' преобразовать выделенный текст в таблицу:
Selection.ConvertToTable Separator:="°", AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
.Style = "Сетка таблицы"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.Rows.HeightRule = wdRowHeightAtLeast
.Rows.Height = CentimetersToPoints(0.7)
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(0.7)
End With

'переход в конец документа:
Selection.EndOf Unit:=wdStory, Extend:=wdMove

' включить перерисовку (обновление) экрана:
Application.ScreenUpdating = True

End Sub