Sub ВставитьТекстОчиститьИОформить()
Dim rng As Range
Dim para As Paragraph
Dim colParas As Collection
Dim i As Long
' 1. Запомнить начало
Dim startPos As Long
startPos = Selection.Start
' 2. Вставка текста из буфера
On Error Resume Next
Selection.PasteSpecial Link:=False, _
DataType:=wdPasteText, _
Placement:=wdInLine, _
DisplayAsIcon:=False
If Err.Number <> 0 Then
MsgBox "Не удалось вставить текст. Проверьте, скопированы ли данные."
Exit Sub
End If
On Error GoTo 0
' 3. Выделить вставленный диапазон
Selection.SetRange Start:=startPos, End:=Selection.End
Set rng = Selection.Range
' 4. Полная очистка форматирования
rng.ClearFormatting
rng.ParagraphFormat.Reset
' 5. Обнулить интервалы и отступы
With rng.ParagraphFormat
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacingRule = wdLineSpaceSingle
.FirstLineIndent = 0
.LeftIndent = 0
.RightIndent = 0
.CharacterUnitFirstLineIndent = 0
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
End With
' 6. Шрифт Times New Roman, 11 пт
With rng.Font
.Name = "Times New Roman"
.Size = 11
End With
' 7. Первая буква каждого слова — заглавная
rng.Case = wdTitleWord
' 8. Добавить по пустой строке сверху и снизу
rng.InsertParagraphBefore ' вставит пустой абзац перед текстом и расширит rng
rng.InsertParagraphAfter ' вставит пустой абзац после текста и расширит rng
' 9. Применить тот же шрифт и интервалы к пустым строкам
With rng.Font
.Name = "Times New Roman"
.Size = 11
End With
With rng.ParagraphFormat
.SpaceAfter = 0
.SpaceBefore = 0
End With
' 10. Собрать непустые абзацы для нумерации
Set colParas = New Collection
For Each para In rng.Paragraphs
If Len(para.Range.Text) > 1 Then ' пустая строка содержит только символ конца абзаца
colParas.Add para
End If
Next para
' 11. Пронумеровать: 1., 2. и т.д.
i = 1
For Each para In colParas
para.Range.InsertBefore i & ". "
i = i + 1
Next para
' 12. Показать результат и снять выделение
rng.Select
Selection.Collapse Direction:=wdCollapseEnd
End Sub