gevonden woord plakken in aanliggende cel

[tobo100]

Allen,

Wie kan mij helpen aan een stukje vba code
die vanuit een opgegeven range woorden gaat zoeken in een andere kolom.
en indien gevonden dit woord gaat plakken in een aanliggende cel.

 

[tobo100]

Graag in VBA...
vergeten te vermelden
De woorden lijst heeft een variabele lengte

 

[AHulpje]

Sub Zoek_en_plak()
    Dim rijTekst As Long
    Dim rijZoekwoord As Long
    Dim rijenTekst As Long
    Dim rijenZoekwoord As Long
    rijenTekst = Range("C1").End(xlDown).Row
    rijenZoekwoord = Range("E1").End(xlDown).Row
    Columns("B:B").ClearContents
    For rijZoekwoord = 2 To rijenZoekwoord
        For rijTekst = 2 To rijenTekst
            If InStr(1, Cells(rijTekst, 3), Cells(rijZoekwoord, 5), vbTextCompare) > 0 Then
                Cells(rijTekst, 2) = Cells(rijTekst, 2) & Cells(rijZoekwoord, 5)
            End If
        Next
    Next
End Sub

 

[tobo100]

Helemaal super, werkt als een trein
Dankjewel voor je AHULP

 

[HSV]

Of met een lusje minder.

Sub hsv()
Dim sv, i As Long
sv = Cells(1, 2).CurrentRegion.Columns(3).Offset(, -1).Resize(, 2)
With CreateObject("VBScript.RegExp")
   .Pattern = Join(Application.Transpose(Range("e2", Cells(Rows.Count, 5).End(xlUp))), "|")
   .Ignorecase = True
     For i = 2 To UBound(sv)
       If .test(sv(i, 2)) Then sv(i, 1) = .Execute(sv(i, 2)) (0)
     Next i
 End With
Cells(1, 2).CurrentRegion.Columns(3).Offset(, -1).Resize(, 2) = sv
End Sub

Of voor meerdere gevonden woorden in de zin..

Sub hsv()
Dim sv, i As Long, m, mm
sv = Cells(1, 2).CurrentRegion.Columns(3).Offset(, -1).Resize(, 2)
With CreateObject("VBScript.RegExp")
   .Pattern = Join(Application.Transpose(Range("e2", Cells(Rows.Count, 5).End(xlUp))), "|")
   .Ignorecase = True  'niet hoofdletter gevoelig.
   .Global = True  'meerdere woorden zoeken
     For i = 2 To UBound(sv)
       sv(i,1) = ""
       If .test(sv(i, 2)) Then  'indien gevonden
       Set m = .Execute(sv(i, 2))
        For Each mm In m
          sv(i, 1) = sv(i, 1) & IIf(sv(i, 1) = "", "", "; ") & mm.Value
        Next mm
       End If
     Next i
 End With
Cells(1, 2).CurrentRegion.Columns(3).Offset(, -1).Resize(, 2) = sv
End Sub

 

[JEC.]

Al vraag je er niet om, toch een formule optie

=LET(z;TRANSPOSE(E2:E6);BYROW(IF(ISNUMBER(SEARCH(z;C2:C11));z;"");LAMBDA(a;TEXTJOIN(", ";;a))))

 

[JEC.]

Power Query kan ook nog

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    trf = Table.TransformColumns(Source,
         {
             {"Tekst", each 
                   List.Accumulate(tbl_woorden[Zoekwoorden],"",(s,c)=>  
                        if Text.PositionOf(Text.Upper(_),Text.Upper(c)) > -1 then s & (if s = "" then "" else ", ") & c 
                        else s
                   )
             }
        })
in
    trf