VBA Excel. Извлечение выбранных слов из ячеек

Извлечение выбранных слов или словосочетаний из строк, записанных в ячейки Excel, с помощью кода VBA. Выбор слов по индексу, а словосочетаний — удалением лишнего.

Содержание

Извлечение слов из строки

Иногда работа с текстовыми данными в Excel требует извлечения из строк отдельных слов или словосочетаний. Например, если в выгрузке списка товаров наименования размещены в одной ячейке вместе с краткими описаниями или какими-то лишними характеристиками.

Процесс извлечения отдельных слов из ячеек можно автоматизировать с помощью кода VBA. Макросы ниже позволяют интерактивно выбирать нужное слово (или словосочетание) из каждой строки и записывать его в соседнюю ячейку справа.

Извлечение слов по индексу

Извлечение одного слова из строки, записанной в ячейку Excel, по его порядковому номеру (индексу):

Sub ВыборСловаПоНомеру()
    ' Переменные
    Dim delimiter As String
    Dim rng As Range
    Dim cell As Range
    Dim words() As String
    Dim wordCount As Long
    Dim i As Long
    Dim userInput As Variant
    Dim promptText As String
    Dim trimmedText As String
    
    ' Установите нужный разделитель (по умолчанию пробел)
    delimiter = " "
    
    ' Определяем диапазон для обработки: от активной ячейки до последней непустой в этом столбце
    With ActiveSheet
        Dim lastRow As Long
        lastRow = .Cells(.Rows.count, ActiveCell.Column).End(xlUp).Row
        Set rng = .Range(ActiveCell, .Cells(lastRow, ActiveCell.Column))
    End With
    
    ' Обход всех ячеек в диапазоне
    For Each cell In rng
        ' Пропускаем пустые ячейки
        If Not IsEmpty(cell.Value) Then
            ' Удаляем лишние пробелы (начальные, конечные, множественные)
            trimmedText = Application.WorksheetFunction.Trim(cell.Value)
            
            ' Разбиваем строку на слова по разделителю
            words = Split(trimmedText, delimiter)
            wordCount = UBound(words) - LBound(words) + 1
            
            ' Если слов нет (пустая строка после Trim) - пропускаем
            If wordCount = 0 Then GoTo NextCell
            
            ' Формируем текст приглашения с нумерованным списком слов
            promptText = "Слова в ячейке " & cell.Address(False, False) & ":" & vbCrLf & vbCrLf
            For i = 0 To wordCount - 1
                ' Ограничиваем вывод, если слов слишком много (отображаем первые 10)
                If i < 10 Then
                    promptText = promptText & (i + 1) & ". " & words(i) & vbCrLf
                Else
                    promptText = promptText & "... и еще " & (wordCount - 10) & " слов." & vbCrLf
                    Exit For
                End If
            Next i
            promptText = promptText & vbCrLf & "Введите номер слова и нажмите «ОК»"
            
            ' Запрос номера слова (Type:=1 означает число)
            Do
            
                userInput = Application.InputBox(promptText, "Выбор слова", Type:=1)
                
                ' Если нажата Отмена или превышено количество знаков – завершаем процедуру
                On Error Resume Next
                If userInput = False Then
                        If Err.Number <> 0 Then
                            MsgBox "Превышено количество знаков. Уменьшите количество слов.", vbCritical
                            Exit Sub
                        End If
                    MsgBox "Операция отменена пользователем.", vbInformation
                    Exit Sub
                End If
                
                ' Проверяем, что номер в допустимом диапазоне
                If userInput >= 1 And userInput <= wordCount Then
                    Exit Do
                Else
                    MsgBox "Некорректный номер. Введите число от 1 до " & wordCount & ".", vbExclamation
                End If
            Loop
            
            ' Записываем выбранное слово в соседний столбец справа
            cell.Offset(0, 1).Value = words(userInput - 1)
        End If
NextCell:
    Next cell
    
    MsgBox "Обработка завершена.", vbInformation
End Sub

Sub ВыборСловаПоНомеру()

' Переменные

Dim delimiter As String

Dim rng As Range

Dim cell As Range

Dim words() As String

Dim wordCount As Long

Dim i As Long

Dim userInput As Variant

Dim promptText As String

Dim trimmedText As String

' Установите нужный разделитель (по умолчанию пробел)

delimiter = " "

' Определяем диапазон для обработки: от активной ячейки до последней непустой в этом столбце

With ActiveSheet

Dim lastRow As Long

lastRow = .Cells(.Rows.count, ActiveCell.Column).End(xlUp).Row

Set rng = .Range(ActiveCell, .Cells(lastRow, ActiveCell.Column))

End With

' Обход всех ячеек в диапазоне

For Each cell In rng

' Пропускаем пустые ячейки

If Not IsEmpty(cell.Value) Then

' Удаляем лишние пробелы (начальные, конечные, множественные)

trimmedText = Application.WorksheetFunction.Trim(cell.Value)

' Разбиваем строку на слова по разделителю

words = Split(trimmedText, delimiter)

wordCount = UBound(words) - LBound(words) + 1

' Если слов нет (пустая строка после Trim) - пропускаем

If wordCount = 0 Then GoTo NextCell

' Формируем текст приглашения с нумерованным списком слов

promptText = "Слова в ячейке " & cell.Address(False, False) & ":" & vbCrLf & vbCrLf

For i = 0 To wordCount - 1

' Ограничиваем вывод, если слов слишком много (отображаем первые 10)

If i < 10 Then

promptText = promptText & (i + 1) & ". " & words(i) & vbCrLf

Else

promptText = promptText & "... и еще " & (wordCount - 10) & " слов." & vbCrLf

Exit For

End If

Next i

promptText = promptText & vbCrLf & "Введите номер слова и нажмите «ОК»"

' Запрос номера слова (Type:=1 означает число)

userInput = Application.InputBox(promptText, "Выбор слова", Type:=1)

' Если нажата Отмена или превышено количество знаков – завершаем процедуру

On Error Resume Next

If userInput = False Then

If Err.Number <> 0 Then

MsgBox "Превышено количество знаков. Уменьшите количество слов.", vbCritical

Exit Sub

End If

MsgBox "Операция отменена пользователем.", vbInformation

Exit Sub

End If

' Проверяем, что номер в допустимом диапазоне

If userInput >= 1 And userInput <= wordCount Then

Exit Do

Else

MsgBox "Некорректный номер. Введите число от 1 до " & wordCount & ".", vbExclamation

End If

Loop

' Записываем выбранное слово в соседний столбец справа

cell.Offset(0, 1).Value = words(userInput - 1)

End If

NextCell:

Next cell

MsgBox "Обработка завершена.", vbInformation

End Sub

Ограничение количества слов обусловлено тем, что ограничено количество знаков, допустимых для параметра Prompt диалогового окна InputBox. Я установил 10 слов, так как моя версия VBA Excel допускает загрузку около 10 слов среднего размера. Если количество знаков будет превышено, произойдет ошибка.

Для решения этой проблемы добавлен обработчик ошибок с сообщением о необходимости уменьшить количество отображаемых слов при превышении количества знаков.

Обзор работы макроса

Пользователь активирует первую ячейку столбца с данными.
Макрос определяет диапазон — от активной ячейки до последней непустой в этом столбце.
Для каждой ячейки:
- Очищается строка от лишних пробелов.
- Разбивается на слова по указанному разделителю (по умолчанию — пробел).
- Выводится диалоговое окно с пронумерованным списком слов.
- Пользователь вводит номер слова.
- Выбранное слово записывается в соседнюю ячейку справа.
Если пользователь нажимает «Отмена» в любом окне ввода — макрос немедленно завершается.
По окончании обработки всех ячеек выводится сообщение об успешном завершении.

Результат работы кода

Результат извлечения из ячеек отдельных слов

Настройка под свои задачи

Смена разделителя

По умолчанию используется пробел. Если ваши слова разделены, например, запятой, точкой с запятой или другим символом, измените значение переменной delimiter:

delimiter = ","   ' запятая
delimiter = ";"   ' точка с запятой
delimiter = "|"   ' вертикальная черта

delimiter = "," ' запятая

delimiter = ";" ' точка с запятой

delimiter = "|" ' вертикальная черта

Запись результата

Строка cell.Offset(0, 1).Value означает: записать в ту же строку, но на 1 столбец правее. Если нужно на 2 столбца правее — напишите Offset(0, 2). Чтобы записать в столбец слева — используйте отрицательное число: Offset(0, -1).

Извлечение словосочетаний

Извлечение словосочетания из строки, записанной в ячейку Excel, после ручного удаления лишних слов в текстовом поле диалогового окна:

Sub ВыборСловосочетания()
    ' Переменные
    Dim rng As Range
    Dim cell As Range
    Dim userInput As Variant
    Dim trimmedText As String
    
    ' Определяем диапазон для обработки: от активной ячейки до последней непустой в этом столбце
    With ActiveSheet
        Dim lastRow As Long
        lastRow = .Cells(.Rows.count, ActiveCell.Column).End(xlUp).Row
        Set rng = .Range(ActiveCell, .Cells(lastRow, ActiveCell.Column))
    End With
    
    ' Обход всех ячеек в диапазоне
    For Each cell In rng
        ' Пропускаем пустые ячейки
        If Not IsEmpty(cell.Value) Then
            ' Удаляем лишние пробелы (начальные, конечные, множественные)
            trimmedText = Application.WorksheetFunction.Trim(cell.Value)
            
                userInput = Application.InputBox("Удалите лишнее и нажмите «OK»", "Выбор словосочетания", trimmedText)
                
                ' Если нажата Отмена или превышено количество знаков – завершаем процедуру
                On Error Resume Next
                If userInput = False Then
                        If Err.Number <> 0 Then
                            MsgBox "Превышено количество знаков. Уменьшите количество слов в ячейке: " & cell.Address, vbCritical
                            Exit Sub
                        End If
                    MsgBox "Операция отменена пользователем.", vbInformation
                    Exit Sub
                End If
            
            ' Записываем выбранное словосочетание в соседний столбец справа
            cell.Offset(0, 1).Value = userInput
        End If
    Next cell
    
    MsgBox "Обработка завершена.", vbInformation
End Sub

Sub ВыборСловосочетания()

' Переменные

Dim rng As Range

Dim cell As Range

Dim userInput As Variant

Dim trimmedText As String

' Определяем диапазон для обработки: от активной ячейки до последней непустой в этом столбце

With ActiveSheet

Dim lastRow As Long

lastRow = .Cells(.Rows.count, ActiveCell.Column).End(xlUp).Row

Set rng = .Range(ActiveCell, .Cells(lastRow, ActiveCell.Column))

End With

' Обход всех ячеек в диапазоне

For Each cell In rng

' Пропускаем пустые ячейки

If Not IsEmpty(cell.Value) Then

' Удаляем лишние пробелы (начальные, конечные, множественные)

trimmedText = Application.WorksheetFunction.Trim(cell.Value)

userInput = Application.InputBox("Удалите лишнее и нажмите «OK»", "Выбор словосочетания", trimmedText)

' Если нажата Отмена или превышено количество знаков – завершаем процедуру

On Error Resume Next

If userInput = False Then

If Err.Number <> 0 Then

MsgBox "Превышено количество знаков. Уменьшите количество слов в ячейке: " & cell.Address, vbCritical

Exit Sub

End If

MsgBox "Операция отменена пользователем.", vbInformation

Exit Sub

End If

' Записываем выбранное словосочетание в соседний столбец справа

cell.Offset(0, 1).Value = userInput

End If

Next cell

MsgBox "Обработка завершена.", vbInformation

End Sub

Обзор работы макроса

Пользователь активирует первую ячейку столбца с данными.
Макрос определяет диапазон — от активной ячейки до последней непустой в этом столбце.
Для каждой ячейки:
- Очищается строка от лишних пробелов.
- Выводится диалоговое окно со строкой из ячейки в текстовом поле.
- Пользователь удаляет лишние слова и нажимает «OK».
- Оставшееся словосочетание (слово) записывается в соседнюю ячейку справа.
Если пользователь нажимает «Отмена» в любом окне ввода — макрос немедленно завершается.
По окончании обработки всех ячеек выводится сообщение об успешном завершении.

Результат работы кода

Результат извлечения из ячеек словосочетаний
Эти макросы позволяют превратить монотонную ручную работу по извлечению слов и словосочетаний из ячеек в удобное взаимодействие с диалоговым окном InputBox. Результатом этого являются меньшая утомляемость и экономия рабочего времени.

Содержание рубрики VBA Excel по тематическим разделам со ссылками на все статьи.