Sub ExtractFirstMatchingWordModified()
Dim cell As Range
Dim searchRange As Range
Dim matchRange As Range
Dim words As Variant
Dim found As Boolean
Dim i As Integer
Dim regex As Object
Dim inputString As String
' Create a new Regex object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.IgnoreCase = True
.Pattern = "[,./?!-!]+" ' Regex pattern to match the specified delimiters
End With
' Set the range to search for the first string
Set searchRange = Range("A1:A100") ' Assuming the data is in A1:A100
' Loop through each cell in the search range
For Each cell In searchRange
' Use Regex to replace delimiters with a space in the cell's value
inputString = regex.Replace(cell.Value, " ")
' Split the modified string into words
words = Split(inputString, " ")
found = False
' Loop through each word
For i = LBound(words) To UBound(words)
' Find the first matching word in the array E1:E100
Set matchRange = Range("E1:E100").Find(What:=words(i), LookIn:=xlValues, LookAt:=xlWhole)
' If a match is found, place the word in column B and exit the loop
If Not matchRange Is Nothing Then
cell.Offset(0, 1).Value = words(i)
found = True
Exit For
End If
Next i
' If no match is found, leave the adjacent cell in column B empty
If Not found Then
cell.Offset(0, 1).Value = ""
End If
Next cell
End Sub
