Hello tobiahjadam,
Welcome to the Forum!
This macro may need some changes. It was written using the following assumptions: The keywords are on a separate sheet and in a single column, and the rows being searched are on a separate sheet in a single column.
If your data is not arranged this way then you need to show me how it is arranged. I can then change the macro to work with the data.
Here is the macro code. Data for both sheets starts in cell "A1".
Sub FindAndReplace()
Dim Data As Variant
Dim I As Integer
Dim KeyWord As String
Dim KeyWords As Object
Dim Rng As Range
Dim RngEnd As Range
Dim Wks As Worksheet
Dim Word As Variant
Dim Words As Variant
Set KeyWords = CreateObject("Scripting.Dictionary")
KeyWords.CompareMode = vbTextCompare
Set Wks = Worksheets("Sheet2")
Set Rng = Wks.Range("A1")
Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
Words = IIf(RngEnd.Row < Rng.Row, Rng.Value, Wks.Range(Rng, RngEnd).Value)
For Each Word In Words
If Not KeyWords.Exists(Word) Then
KeyWords.Add Word, 1
End If
Next Word
Set Wks = Worksheets("Sheet1")
Set Rng = Wks.Range("A1")
Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
ReDim Data(1 To Rng.Rows.Count, 1 To 1)
Data = Rng.Value
For I = 1 To UBound(Data, 1)
Words = Split(Data, " ")
For Each Word In Words
If KeyWords.Exists(Word) Then
Data(I, 1) = Word
Exit For
End If
Next Word
Next I
Rng.Value = Data
End Sub
Bookmarks