Sub PasteAndClean()
Dim startPos As Long, endPos As Long
Dim rng As Range
' 1. Запоминаем позицию курсора до вставки
startPos = Selection.Start
' 2. Вставляем из буфера как обычный текст
Selection.PasteSpecial DataType:=wdPasteText, Placement:=wdInLine
' 3. Определяем конечную позицию после вставки
endPos = Selection.End
' Проверка: если ничего не вставилось
If endPos <= startPos Then
MsgBox "В буфере нет текста или вставка не удалась.", vbExclamation
Exit Sub
End If
' 4. Создаём диапазон вставленного текста и выделяем его
Set rng = ActiveDocument.Range(startPos, endPos)
rng.Select
' 5. Преобразуем каждое слово в заглавную букву
rng.Text = StrConv(rng.Text, vbProperCase)
' 6. Обрабатываем все абзацы внутри этого диапазона
Dim para As Paragraph
Dim i As Long
For Each para In rng.Paragraphs
With para
' --- Жёсткое обнуление ВСЕХ интервалов ---
.SpaceBefore = 0
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle ' одинарный межстрочный
' .LineSpacing = 12 ' если нужен фиксированный, раскомментируйте
End With
' Убираем пробелы и табуляции в конце строки
With para.Range
If .Characters.Count > 1 Then
.MoveEnd Unit:=wdCharacter, Count:=-1
Do While .Characters.Count > 0 And _
(.Characters.Last = " " Or .Characters.Last = vbTab)
.Characters.Last.Delete
Loop
End If
End With
Next para
' 7. Удаляем пустые абзацы (лишние строки из Excel)
For i = rng.Paragraphs.Count To 1 Step -1
Set para = rng.Paragraphs(i)
Dim txt As String
txt = para.Range.Text
txt = Replace(txt, " ", "")
txt = Replace(txt, vbTab, "")
If Len(txt) = 1 And Asc(txt) = 13 Then ' остался только маркер абзаца
para.Range.Delete
End If
Next i
MsgBox "✅ Готово! Интервал после абзаца = 0, лишние строки удалены, регистр исправлен.", vbInformation
End Sub