Висячие предлоги,как убрать?

[Alena029]

Всем добрый день!

Ребят, помогите пожалуйста (если это возможно конечно))))
Надо отредактировать большой объем текста, убрать висячие предлоги,союзы и т.д. с конца строки (ворд 2013).

Есть такой вариант решения с помощью автозамены:

В «Найти» введите строку «([ ^s])([а-яА-Яa-zA-Z]{1;2}) ([а-яА-Яa-zA-Z])», в поле «Заменить на», введите строку «\1\2^s\3»

Предлоги,союзы приклеиваются с помощью неразрывного пробела к следующему слову.
Все работает хорошо, НО, приклеиваются они не только в конце строки , а по всему тексту.
Можно ли как-то сделать так чтобы это работала только с конечными символами???
или есть другое решение?

[Казанский]

Попробуйте макрос:

Sub ВисячиеПредлоги()
Dim s$, n&
  Selection.HomeKey Unit:=wdStory
  Do
    Selection.EndKey Unit:=wdLine
    If Selection.End + 1 >= ActiveDocument.Range.End Then Exit Do
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    s = Selection.Text
    If s = vbCr Then  'пустой абзац, выделение сместилось на строку вверх!
      Selection.MoveDown Unit:=wdLine, Count:=1
    ElseIf Right$(s, 1) = " " And (Len(s) = 2 Or Len(s) = 3) Then
      Selection.EndKey Unit:=wdLine
      Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
      Selection.TypeText Text:=Chr(160) 'неразрывный пробел; происходит переход на сл. строку
      n = n + 1
      Selection.MoveUp Unit:=wdLine, Count:=1
    End If
    Selection.MoveDown Unit:=wdLine, Count:=1
  Loop
MsgBox "Выполнено замен: " & n, vbInformation
End Sub

[Alena029]

"Казанский"
-спасибо большое предлоги отлично "слетают" на следующую строку, а можно чтобы слова после которых запятая не "слетали", ато они тоже приклеиваются неразрывным к следующему слову?

[Казанский]

Изменил условие: перед заменяемым пробелом должна быть буква

Sub ВисячиеПредлоги1()
Dim s$, n&
  Selection.HomeKey Unit:=wdStory
  Do
    Selection.EndKey Unit:=wdLine
    If Selection.End + 1 >= ActiveDocument.Range.End Then Exit Do
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    s = Selection.Text
    If s = vbCr Then  'пустой абзац, выделение сместилось на строку вверх!
      Selection.MoveDown Unit:=wdLine, Count:=1
    ElseIf LCase$(Right$(s, 2)) Like "[a-zа-яё] " And (Len(s) = 2 Or Len(s) = 3) Then
      Selection.EndKey Unit:=wdLine
      Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
      Selection.TypeText Text:=Chr(160) 'неразрывный пробел; происходит переход на сл. строку
      n = n + 1
      Selection.MoveUp Unit:=wdLine, Count:=1
    End If
    Selection.MoveDown Unit:=wdLine, Count:=1
  Loop
MsgBox "Выполнено замен: " & n, vbInformation
End Sub

[Alena029]

"Казанский", я Вам на почту указанную в профиле письмо отправила...

[Sasha_Smirnov]

Сообщение от Alena029

приклеиваются они не только в конце строки

Alena029, а что в этом плохого?

[korney4]

Сообщение от Казанский

Изменил условие: перед заменяемым пробелом должна быть буква

Sub ВисячиеПредлоги1()
Dim s$, n&
  Selection.HomeKey Unit:=wdStory
  Do
    Selection.EndKey Unit:=wdLine
    If Selection.End + 1 >= ActiveDocument.Range.End Then Exit Do
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    s = Selection.Text
    If s = vbCr Then  'пустой абзац, выделение сместилось на строку вверх!
      Selection.MoveDown Unit:=wdLine, Count:=1
    ElseIf LCase$(Right$(s, 2)) Like "[a-zа-яё] " And (Len(s) = 2 Or Len(s) = 3) Then
      Selection.EndKey Unit:=wdLine
      Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
      Selection.TypeText Text:=Chr(160) 'неразрывный пробел; происходит переход на сл. строку
      n = n + 1
      Selection.MoveUp Unit:=wdLine, Count:=1
    End If
    Selection.MoveDown Unit:=wdLine, Count:=1
  Loop
MsgBox "Выполнено замен: " & n, vbInformation
End Sub

не подскажете каким образом изменить макрос, чтобы переносился знак № в конце строки?

[korney4]

не подскажете каким образом изменить макрос, чтобы переносился знак № в конце строки?

[Казанский]

korney4,
просто замените "№ " (№пробел) на "№^s" (без кавычек) по всему документу.

[Green54]

Сообщение от Казанский

Изменил условие: перед заменяемым пробелом должна быть буква

Sub ВисячиеПредлоги1()
 s$, n&
  Selection.HomeKey Unit:=wdStory
  Do
    Selection.EndKey Unit:=wdLine
    If Selection.End + 1 >= ActiveDocument.Range.End Then Exit Do
    Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
    s = Selection.Text
    If s = vbCr Then  'пустой абзац, выделение сместилось на строку вверх!
      Selection.MoveDown Unit:=wdLine, Count:=1
    ElseIf LCase$(Right$(s, 2)) Like "[a-zа-яё] " And (Len(s) = 2 Or Len(s) = 3) Then
      Selection.EndKey Unit:=wdLine
      Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
      Selection.TypeText Text:=Chr(160) 'неразрывный пробел; происходит переход на сл. строку
      n = n + 1
      Selection.MoveUp Unit:=wdLine, Count:=1
    End If
    Selection.MoveDown Unit:=wdLine, Count:=1
  Loop
MsgBox "Выполнено замен: " & n, vbInformation
End Sub

Отличный макрос, предлоги слетают хорошо.
Но почему то виснет напрочь на таблицах и рисунках.
Может можно переписать действие макроса только на выделенный фрагмент текста?