Определение конца строки

Selection.IPAtEndOfLine

Selection.EndOf Unit:=Word.wdLine, Extend:=Word.wdMove

Sub SimpleReplaceAtEndOfLine(what, forwhat, checkCase)
    exitPoint = False
    With Selection
        With .Find
            .ClearFormatting
            .Text = what
            .Replacement.ClearFormatting
            .Replacement.Text = forwhat
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = checkCase
            .MatchWildcards = False
            Do While .Execute(Replace:=wdReplaceNone)
                exitPoint = True
Dim L&, N&
                L = Selection.Characters.Count
                N = Selection.EndOf(Unit:=Word.wdLine, Extend:=Word.wdMove)
                If (N = 1) And Selection.IPAtEndOfLine Then
                    Selection.MoveEnd Unit:=Word.wdCharacter, Count:=1 - L - N
                    .Execute Replace:=wdReplaceOne
                Else
                    Selection.MoveEnd Unit:=Word.wdCharacter, Count:=2 - L - N
                End If
            Loop
        End With
    End With
End Sub

Sub SimpleReplaceAtEndOfLine(what, forwhat, checkCase)
    With Selection
        .SetRange 0, 0
        With .Find
...

    With Selection.Find
        .Forward = True
        .Wrap = wdFindContinue
    End With

Dim CurrentDoc As Document
Set CurrentDoc = ActiveDocument

Sub test1()
    ActiveDocument.ActiveWindow.View.Type = wdPrintView
    'ActiveDocument.Range(0, 0).Select
    SimpleReplaceAtEndOfLine1 Selection.Range, "(<[Нн]а)([ ]@<)", "\1^s"
End Sub

Sub SimpleReplaceAtEndOfLine1(FindRange As Range, What As String, ForWhat As String)
Dim R As Word.Range
Dim EOL As Boolean
Dim N As Long
    Set R = FindRange.Duplicate
    R.Collapse Direction:=wdCollapseStart
    With R.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = What
        .Replacement.Text = ForWhat
    End With
    Do While R.End < R.StoryLength - 1
        R.Collapse Direction:=wdCollapseEnd
        R.Find.Execute Replace:=wdReplaceNone
        If R.Find.Found <> True Then Exit Do
        If FindRange.Start < FindRange.End Then
            If R.InRange(FindRange) <> True Then Exit Do
        End If
        ' обработка
        R.Select
        N = Selection.EndOf(Unit:=Word.wdLine, Extend:=Word.wdMove)
        EOL = Selection.IPAtEndOfLine
        If (N = 1) And EOL Then
            R.Collapse Direction:=wdCollapseStart
            R.Find.Execute Replace:=wdReplaceOne
        End If
    Loop
End Sub

Sub PerenosPredlogov()    ActiveDocument.ActiveWindow.View.Type = wdPrintView    'ActiveDocument.Range(0, 0).Select    SimpleReplaceAtEndOfLine1 Selection.Range, "", "\1^s"

End Sub

Sub SimpleReplaceAtEndOfLine1(FindRange As Range, What As String, ForWhat As String)
If FindRange.Duplicate = "" Then
MsgBox "Выделите текст!", vbInformation, "Обработка невозможна!"
Exit Sub
End If
Dim R As Word.Range
Dim EOL As Boolean
Dim N As Long
Dim arrWhat
arrWhat = Array("(<[Нн]а)", "(<[Ии]ли)", "(<[Вв]о)", "(<[Вв]иду)", "(<[Вв]опреки)", "(<[Вв]след)", "(<[Вв]следствие)", "(<[Дд]ля)", "(<[Дд]о)", "(<[Ии]з)", "(<[Ии]з-за)", "(<[Зз]а)", "(<[Ии]сключая)", "(<[Кк]о)", "(<[Кк]роме)", "(<[Нн]а)", "(<[Мм]ежду)", "(<[Нн]ад)", "(<[Нн]е)", "(<[Оо]б)", "(<[Оо]бо)", "(<[Оо]коло)", "(<[Оо]т)", "(<[Пп]еред)", "(<[Пп]о)", "(<[Пп]од)", "(<[Пп]ред)", "(<[Пп]ри)", "(<[Пп]ро)", "(<[Пп]ротив)", "(<[Пп]ри)", "(<[а-яА-Яa-zA-Z]{1})")
Dim i As Integer
i = 1
For i = 1 To 3
    For Each mark In arrWhat
    Set R = FindRange.Duplicate
    R.Collapse Direction:=wdCollapseStart
    With R.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = mark & "([ ]@<)"
        .Replacement.Text = ForWhat
    End With
    Do While R.End < R.StoryLength - 1
        R.Collapse Direction:=wdCollapseEnd
        R.Find.Execute Replace:=wdReplaceNone
        If R.Find.Found <> True Then Exit Do
        If FindRange.Start < FindRange.End Then
            If R.InRange(FindRange) <> True Then Exit Do
        End If
        ' обработка
        R.Select
        N = Selection.EndOf(Unit:=Word.wdLine, Extend:=Word.wdMove)
        EOL = Selection.IPAtEndOfLine
        If (N = 1) And EOL Then
            R.Collapse Direction:=wdCollapseStart
            R.Find.Execute Replace:=wdReplaceOne
        End If
    Loop
    Next
i = i + 1
Next
End Sub

Dim RC As Integer
Sub PerenosPredlogov()
    If VBA.Len(Selection.Range.Text) = 0 Then
    MsgBox "Выделите текст!", vbInformation, "Обработка невозможна!"
    Exit Sub
    End If
ActiveDocument.ActiveWindow.View.Type = wdPrintView
Application.ScreenUpdating = False
Dim FRange As Word.Range
Set FRange = Selection.Range
Dim arrWhat
Dim What$, i As Byte, p%, h%, prog%
'список членов предложения для переноса
    arrWhat = Array(0, "на", "во", "виду", "вопреки", "вслед", "для", "до", "из", "из-за", "за", "ко", "кроме", "на", "между", _
"над", "не", "об", "обо", "около", "от", "перед", "по", "под", "пред", "при", "про", "против", "со", "то", "да", "даже", _
"едва", "если", "затем", "либо", "когда", "как", "однако", "отчего", "перед", "пока", "после", "потому", "так", "также", "тем", _
"тоже", "тогда", "хотя", "чем", "что", "чтоб", "чтобы", "не", "ни", "это", "или") ', "поскольку", "исключая", "вследствие", "притом", "причем")
'переменные для отображения прогресса
p = 0
h = (UBound(arrWhat) + 1) * 3
prog = 0
RC = 0
Application.StatusBar = "Выполнено: 1 %" & ". Количество переносов: " & RC
i = 1
For i = 1 To 3
    For Each mark In arrWhat
        If mark <> 0 Then
        What = "(<[" & UCase(Left(mark, 1)) & Left(mark, 1) & "]" & Mid(mark, 2) & ")([ ]@<)" 'обработка предлогов для regex
        Else
        What = "(<[а-яА-Яa-zA-Z]{1})([ ]@<)" 'одиночные символы
        End If
        SimpleReplaceAtEndOfLine1 FRange, What, "\1^s"
        'счёт прогресса
        p = p + 1
        prog = p / h * 100
        Application.StatusBar = "Выполнено: " & prog & "%" & ". Количество переносов: " & RC
     Next
DoEvents
Next i
MsgBox "Выполнено! " & " Количество переносов: " & RC
Application.ScreenUpdating = True
End Sub
Sub SimpleReplaceAtEndOfLine1(FindRange As Range, What As String, ForWhat As String)
Dim R As Word.Range
Dim EOL As Boolean
Dim N As Long
Set R = FindRange.Duplicate
R.Collapse Direction:=wdCollapseStart
    With R.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = What
        .Replacement.Text = ForWhat
    End With
        ' поиск
        Do While R.End < R.StoryLength - 1
            R.Collapse Direction:=wdCollapseEnd
            R.Find.Execute Replace:=wdReplaceNone
            If R.Find.Found <> True Then Exit Do
            If FindRange.Start < FindRange.End Then
                If R.InRange(FindRange) <> True Then Exit Do
            End If
            ' обработка
            R.Select
            N = Selection.EndOf(Unit:=Word.wdLine, Extend:=Word.wdMove)
            EOL = Selection.IPAtEndOfLine
            If (N = 1) And EOL Then
                R.Collapse Direction:=wdCollapseStart
                R.Find.Execute Replace:=wdReplaceOne
                RC = RC + 1
            End If
        DoEvents
        Loop
End Sub