Auto Grab Word From Text String When Cell is Updated

jbds

You didn't provide a file (at first) so I created one (the first file attached).

This event macro (behind sheet1) detects when A32 changes:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("A32")) Is Nothing Then Exit Sub
' if A32 changed, run sub
Call ExtractWords

End Sub

It calls another macro (in Module 1) where you need to change the bits in bold (and use the comments to understand what is happening):

Sub ExtractWords()

Dim Inpt As Range, Inp As Range, Cl As Range
Dim xWords() As Variant, n As Long, Offs As Long

' list your words (case sensitive) and surround with spaces if you want whole words only
xWords = Array("who", "certain", "be", "words", "out")
' state range to check
Set Inpt = Range("A32:A33")
' say the number columns to the right the words will be copied, 1 or more
Offs = 2

'clear output area and draw borders
With Inpt
    With .Offset(0, Offs).Resize(.Rows.Count, UBound(xWords) + 1)
        .Clear
        .Borders.LineStyle = xlContinuous
        .VerticalAlignment = xlTop
    End With
End With

' loop though range
For Each Cl In Inpt
    'loop through array to check cells against words
    For n = LBound(xWords) To UBound(xWords)
        If InStr(Cl.Value, xWords(n)) > 0 Then
            ' list (in array order)
            Cl.Offset(0, Offs + n) = xWords(n)
        End If
    Next n
Next Cl
' tell user
MsgBox "Extracted words for range " & Inpt.Address(0, 0) & ", listed in bordered area"

End Sub

The array of words could be any size but see the note above that line (and notice what "be" is listed since it's part of "maybe" in my example text).

That macro can be run manually from the blue button on the sheet too.

REViSION 10 February 2023

Given your sample file and clarification that the changed text will always have words separated by commas, the second file below uses the Worksheet_Change event to detect when the cell A32 (in bold below) changes and extract the words into the next free row below that cell. I've added comments so you can see what's happening:

Private Sub Worksheet_Change(ByVal Target As Range)

' define which cell to check (and do nothing if some other cell changed)
If Intersect(Target, Range("A32")) Is Nothing Or Target.CountLarge > 1 Then Exit Sub

Dim xWords As Variant, lRw As Long

' stop this macro being retriggered by actions
Application.EnableEvents = False
'get last used row in target's column
lRw = Cells(Rows.Count, Target.Column).End(xlUp).Row

' put words or phrases (each separated by a comma) into an array
xWords = Split(Target.Value, ",")
' copy the array into next free row
Cells(lRw + 1, Target.Column).Resize(, UBound(xWords) + 1) = xWords

' allow events
Application.EnableEvents = True
' tell user
MsgBox "Extracted " & UBound(xWords) + 1 & " from " & Target.Address(0, 0) & ", now listed in row " & lRw + 1

End Sub

Hope this helps. if so, please mark this Answer as Seelected (in accordance with the rules of the Forum)