Public Function WordsChange(St As String, Rule_s As Range, Rule_e As Range)
    Dim arrString() As String
    Dim j As Integer
    Dim ps As String, pe As String
    arrString = Split(St, " ")
    For j = LBound(arrString) To UBound(arrString)
        If Not IsError(Application.VLookup(arrString(j), Rule_s, 1, 0)) Then
            ps = ps & "" & arrString(j)
            arrString(j) = ""
        ElseIf Not IsError(Application.VLookup(arrString(j), Rule_e, 1, 0)) Then
            pe = pe & "" & arrString(j)
            arrString(j) = ""
        End If
    Next j
    WordsChange = WorksheetFunction.Trim(ps & " " & Join(arrString, " ") & " " & pe)
End Function

Sub Переместить_слово_в_конец()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False

 Dim c, r, Lastrow As Long, Sl
 
Sl = " " & InputBox("Введите СЛОВОСОЧЕТАНИЕ!!! для переноса в Конец фразы!") & " "
  
  Lastrow = Cells(Rows.Count, 1).End(xlUp).Row

  c = 1 
  r = 13 
  Do
  If r > Lastrow Then
    Exit Do
  End If
  
If Cells(r, c).EntireRow.Hidden <> True Then
Cells(r, c).Select
Cells(r, c) = " " & Cells(r, c) & " "

Set k = Selection.Find(What:=Sl, LookIn:=xlValues, LookAt:=xlPart)
If k Is Nothing Then
Cells(r, c) = Application.Trim(Cells(r, c))
Else

Old = Cells(r, c).Value
Cells(r, c).Value = Replace(Old, Sl, " ") & Sl
    Selection.Replace What:="!", Replacement:="! ", LookAt:=xlPart
    Selection.Replace What:=",", Replacement:=", ", LookAt:=xlPart
    Selection.Replace What:=".", Replacement:=". ", LookAt:=xlPart

Cells(r, c) = Application.Trim(Cells(r, c))
End If
End If

 r = r + 1
    Loop
    
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True


End Sub