Sub MoveWordToStart()
    Dim cell As Range
    Dim originalText As String
    Dim words() As String
    Dim targetWord As String ' Словарь, которое нужно переместить
    Dim newText As String
    Dim i As Long
 
    ' Задайте слово, которое нужно переместить.
    ' Например: targetWord = "Ключевое"
    targetWord = InputBox("Введите слово для перемещения в начало:", "Перемещение слова")
 
    If targetWord = "" Then Exit Sub ' Если пользователь нажал Отмена
 
    For Each cell In Selection ' Работаем только с выделенными ячейками
        originalText = cell.Value
        words = Split(originalText, " ") ' Разбиваем строку по пробелам
 
        Dim found As Boolean
        found = False
 
        For i = LBound(words) To UBound(words)
            If words(i) = targetWord Then ' Нашли слово
                ' Собираем новую строку: целевое слово + остальные слова
                newText = words(i) & " "
                For j = LBound(words) To UBound(words)
                    If i <> j Then ' Добавляем все, кроме найденного слова
                        newText = newText & words(j) & " "
                    End If
                Next j
                cell.Value = Trim(newText) ' Обрезаем лишние пробелы и записываем
                found = True
                Exit For ' Переходим к следующей ячейке
            End If
        Next i
        ' Если слово не найдено, ничего не делаем
    Next cell
End Sub

Sub MoveWordToStart()
    Dim cell As Range
    Dim originalText As String
    Dim words() As String
    Dim targetWord As String ' Словарь, которое нужно переместить
    Dim newText As String
    Dim i As Long

    ' Задайте слово, которое нужно переместить.
    ' Например: targetWord = "Ключевое"
    targetWord = InputBox("Введите слово для перемещения в начало:", "Перемещение слова")

    If targetWord = "" Then Exit Sub ' Если пользователь нажал Отмена

    For Each cell In Selection ' Работаем только с выделенными ячейками
        originalText = cell.Value
        words = Split(originalText, " ") ' Разбиваем строку по пробелам

        Dim found As Boolean
        found = False

        For i = LBound(words) To UBound(words)
            If words(i) = targetWord Then ' Нашли слово
                ' Собираем новую строку: целевое слово + остальные слова
                newText = words(i) & " "
                For j = LBound(words) To UBound(words)
                    If i <> j Then ' Добавляем все, кроме найденного слова
                        newText = newText & words(j) & " "
                    End If
                Next j
                cell.Value = Trim(newText) ' Обрезаем лишние пробелы и записываем
                found = True
                Exit For ' Переходим к следующей ячейке
            End If
        Next i
        ' Если слово не найдено, ничего не делаем
    Next cell
End Sub

Sub MoveWordToSecondPosition()
    Dim cell As Range
    Dim strText As String
    Dim words() As String
    Dim targetWord As String ' Слово, которое нужно переместить на второе место
    Dim newText As String
    Dim i As Long

    ' --- НАСТРОЙКИ ---
    targetWord = "КлючевоеСлово" ' <--- Введите сюда слово, которое нужно сделать вторым
    ' ---------------

    For Each cell In Selection ' Работаем с выделенными ячейками
        strText = cell.Value
        words = Split(strText, " ") ' Разбиваем текст на массив слов

        If UBound(words) >= 1 Then ' Проверяем, есть ли хотя бы 2 слова

            Dim wordIndex As Long
            wordIndex = -1 ' Индекс искомого слова

            ' Ищем индекс нашего слова (если оно есть)
            For i = LBound(words) To UBound(words)
                If words(i) = targetWord Then
                    wordIndex = i
                    Exit For
                End If
            Next i

            If wordIndex > 0 Then ' Если слово найдено и оно не первое
                ' Удаляем слово из его текущей позиции
                Dim tempArray() As String
                ReDim tempArray(0 To UBound(words) - 1)
                Dim j As Long
                j = 0
                For i = LBound(words) To UBound(words)
                    If i <> wordIndex Then
                        tempArray(j) = words(i)
                        j = j + 1
                    End If
                Next i

                ' Вставляем слово на вторую позицию (индекс 1)
                Dim finalWords() As String
                ReDim finalWords(0 To UBound(tempArray))
                finalWords(0) = tempArray(0) ' Первое слово
                finalWords(1) = targetWord    ' Искомое слово (теперь второе)
                For i = 1 To UBound(tempArray)
                    finalWords(i + 1) = tempArray(i)
                Next i

                ' Собираем обратно в строку
                cell.Value = Join(finalWords, " ")
            ElseIf wordIndex = 0 Then ' Если искомое слово было первым
                ' Просто меняем местами первое и второе слово (если есть)
                If UBound(words) >= 1 Then
                    Dim temp As String
                    temp = words(0)
                    words(0) = words(1)
                    words(1) = temp
                    cell.Value = Join(words, " ")
                End If
            End If
        End If
    Next cell
End Sub