Using VBA, how can I search for multiple strings within a defined range?

Question

If I have a long list of text in Column A, and a short list of words in Column C, what would be the best way to go about searching each cell in A for any of the words in C, and copy and paste the ones that match out into Column B?

The code I have written so far is as follow

   Sub ListKeywordQualifier()

Dim Rng As Range
Dim Keyword As Range
Dim Chunk As Range
Dim x As Long

x = 1

While x <= 5000
Set Rng = Range("A" & x)
Set Chunk = Range("C1", "C100")

Application.ScreenUpdating = True
Range("D1").Value = x
If Application.WorksheetFunction.CountIf(Chunk, Rng) = 0 Then
x = x + 1

ElseIf Application.WorksheetFunction.CountIf(Chunk, Rng) = 1 Then
Rng.Copy
Rng.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,         SkipBlanks _
    :=False, Transpose:=False
x = x + 1

End If

Wend

End Sub

However, this will onl;y give me exact matches between the two. Is it possible to do the same, but have text that appears in Column C, while only making up part of Column A, trigger the copy/paste line?

Thanks

Answer 1

your countif is not working because it is a worksheet function, to implement countif.... you need to write it like WorksheetFunction.CountIf . Still your code is not looking Good , Try This!

 Sub ListKeywordQualifier()

 Dim Rng(50) As String
 Dim Chunk(50) As String
 Dim i As Long
 i = 1

 '' Take a value From 3rd Column this works for 10 cells , 
 For i = 1 To 10
 Chunk(i) = Cells(i, 3)

  ''Search it in 1st Column in 10 cells
 For j = 1 To 10
   Rng(j) = Cells(j, 1)

 ''If it matches 

   If Chunk(i) = Rng(j) Then

''Then copy that value to Second Column

  Cells(i, 2).Value = Rng(j)

End If

Next j

Next i

End Sub

This is just to give you an idea , you still need make changes Thanks

Answer 2

Consider:

Sub ListKeywordQualifier()
   Dim A As Range, C As Range, aa As Range, cc As Range
   Dim K As Long, va, vc, boo As Boolean
   Set A = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
   Set C = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
   K = 1

   For Each aa In A
      va = aa.Value
      boo = False
      For Each cc In C
         If InStr(1, va, cc.Value) > o Then boo = True
      Next cc
      If boo Then
         aa.Copy Cells(K, "B")
         K = K + 1
      End If
   Next aa
End Sub

Before:

and after: