Extract multiple keywords from text string

[HughT]

I have searched the forum but I can't find anything that quite matches this.

This is for a healthy eating project. Students record their meals in a daily diary. This is random unformatted text in a single cell (B1, B2 etc). There is a keyword list of healthy foods, each item being in a separate cell. What I would like to do is search the random text for occurrences of the keywords and return the keywords in another cell adjacent to the text cell. I would then like to be able to search the returned cells by the keyword list.

So:

Keywords (each in a separate cell, but doesn't have to be in Column A):

A1 Apple
A2 Fries
A3 Salad
A4 Burger
etc

Text (in B1)
Today I ate a burger with fries, and had an apple afterwards.

Result (in C1)
Apple Fries Burger [order is not important]

C1 to C20 (etc) will be the searchable data. I want to be able to search this by each keyword in the range A1:A4, ie 'Apple', 'Fries', 'Salad' etc so I can see who has been eating Apples, Fries, etc. Using column filters will display the contents of every cell, so if some comedian enters the whole range A1:A4 (which will actually be much larger) the filter will also return the whole range, so I need an alternative method.

I possible I would like to do this by a formula rather than VBA as I have to hand this over to someone who will not understand VBA, and can add to or alter the contents of the lookup range (A1:A4) simply by adding to it or overtyping the existing contents.

Thank you for your help.

 

[Peter_SSs]

Try this one.

Sub Components_v3()
  Dim RX As Object
  Dim aResults As Variant
  Dim c As Long, i As Long, ubaResults As Long, lr As Long
  Dim sComp As String
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Ignorecase = True
  With Worksheets("Sheet1")
    .Range("B2", .Range("B" & Rows.Count).End(xlUp).Offset(1)).ClearContents
    aResults = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2).Value
  End With
  ubaResults = UBound(aResults)
  With Sheets("Sheet2")
    For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
      lr = .Cells(.Rows.Count, c).End(xlUp).Row
      If lr > 1 Then
        sComp = .Cells(1, c).Value
        If lr = 2 Then
          RX.Pattern = .Cells(lr, c).Value
        Else
          RX.Pattern = Join(Application.Transpose(.Range(.Cells(2, c), .Cells(lr, c))), "|")
        End If
        RX.Pattern = "\b(" & Replace(Replace(RX.Pattern, "(", "\("), ")", "\)") & ")(?= |$)"
        For i = 1 To ubaResults
          If IsEmpty(aResults(i, 2)) Then
            If RX.Test(aResults(i, 1)) Then aResults(i, 2) = sComp
          End If
        Next i
      End If
    Next c
  End With
  Sheets("Sheet1").Range("A2:B2").Resize(ubaResults).Value = aResults
End Sub

 

[iazeemkhan]

Dear Sir,

Its running properly with brackets also Sir.

Fantastic, superb.... I am very very very thankful to you Sir. You are a genius. Hats off to you Sir. Thanks a lot.

Best Regards

 

[Peter_SSs]

Dear Sir,

Its running properly with brackets also Sir.

Fantastic, superb.... I am very very very thankful to you Sir. You are a genius. Hats off to you Sir. Thanks a lot.

Best Regards

You're welcome. Glad we got there in the end.

 

[iazeemkhan]

Dear Sir,

One small request in connection with above. This is for future query actually, the last query solved superbly and I am very grateful to you Sir for that.

Sir, If you can please Return the found value in column C after Result column, I mean the Item found in Description appear in Column C.

Lots of Thanks.

Best Regrads.

 

[Peter_SSs]

Try

Sub Components_v4()
  Dim RX As Object
  Dim aResults As Variant
  Dim c As Long, i As Long, ubaResults As Long, lr As Long
  Dim sComp As String
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Ignorecase = True
  With Worksheets("Sheet1")
    .Range("B2", .Range("B" & Rows.Count).End(xlUp).Offset(1)).Resize(, 2).ClearContents
    aResults = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3).Value
  End With
  ubaResults = UBound(aResults)
  With Sheets("Sheet2")
    For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
      lr = .Cells(.Rows.Count, c).End(xlUp).Row
      If lr > 1 Then
        sComp = .Cells(1, c).Value
        If lr = 2 Then
          RX.Pattern = .Cells(lr, c).Value
        Else
          RX.Pattern = Join(Application.Transpose(.Range(.Cells(2, c), .Cells(lr, c))), "|")
        End If
        RX.Pattern = "\b(" & Replace(Replace(RX.Pattern, "(", "\("), ")", "\)") & ")(?= |$)"
        For i = 1 To ubaResults
          If IsEmpty(aResults(i, 2)) Then
            If RX.Test(aResults(i, 1)) Then
              aResults(i, 2) = sComp
              aResults(i, 3) = RX.Execute(aResults(i, 1))(0)
            End If
          End If
        Next i
      End If
    Next c
  End With
  With Sheets("Sheet1").Range("A2:C2").Resize(ubaResults)
    .Value = aResults
    .Columns.AutoFit
  End With
End Sub

 

[iazeemkhan]

Dear Sir,

Fantastic Sir, so nice of you. I am grateful to you Sir. Have a great Day.

Best Regards

 

[Peter_SSs]

Dear Sir,

Fantastic Sir, so nice of you. I am grateful to you Sir. Have a great Day.

Best Regards

No problem. Same to you.

 

[iazeemkhan]

Dear Sir,

At the outset I am extreamly sorry to disturbe you again in this issue.

Sir, In the same File, there will be some more to be done after last result as per my Department head. Sir, is there any way to add all the ITEMS found in Description in C column with comma i.e. Heat Detector, Multi Sensor, Smoke detector, etc etc.
[TABLE="width: 249"]
<tbody>[TR]
[TD]Fire alarm[/TD]
[/TR]
[TR]
[TD]Heat Detector[/TD]
[/TR]
[TR]
[TD]Heat Detector with sounder[/TD]
[/TR]
[TR]
[TD]Multi Sensor[/TD]
[/TR]
[TR]
[TD]Multi Sensor detector with sounder[/TD]
[/TR]
[TR]
[TD]Smoke detector[/TD]
[/TR]
[TR]
[TD]Smoke dector with sounder[/TD]
[/TR]
[TR]
[TD]Smoke detector with remote indicator[/TD]
[/TR]
[TR]
[TD]Duct Smoke Detector[/TD]
[/TR]
[TR]
[TD]Munual call break point[/TD]
[/TR]
[TR]
[TD]Sounder horn[/TD]
[/TR]
[TR]
[TD]Strobe Light[/TD]
[/TR]
[TR]
[TD]Sounder & Strobe Flasher[/TD]
[/TR]
[TR]
[TD]Fire Telephone Jack[/TD]
[/TR]
[TR]
[TD]Fire Telephone Handset[/TD]
[/TR]
[TR]
[TD]Fireman Panel[/TD]
[/TR]
[TR]
[TD]Wall Beam Receiver[/TD]
[/TR]
[TR]
[TD]Wall Beam Transmitter[/TD]
[/TR]
[TR]
[TD]Module[/TD]
[/TR]
[TR]
[TD]Interface Unit[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Sir, this is my core file and will be needing your precious time, cooperation and advice.

Sir, thank you very much.

Best regards
Take care

 

[Peter_SSs]

... is there any way to add all the ITEMS found in Description in C column ...

In all the sample data we have had I don't know that we have had any descriptions that contained more than one Item did we?

In any case is post 49 that you kept referring me to, you specifically stated (& emphasised in bold) that we only had to find any one item, so that is all my code has been searching for.

If we found any one Item in Description (Sheet 1) then we have to get its Component name display in Result column (Sheet 1) next to Description column. NOTE: COMPONENT Name to be display not the ITEM Name.

The requirements keep changing.
If all the requirements are know at the start, the best method to achieve them can be assessed. Otherwise it is easy to go down the wrong path & have to repeatedly back-track.

 

[iazeemkhan]

Dear Sir,

You are absolutely right Sir, this almost the same words I spoke to the head of the department. I am really apologies to you for this.

The Result we got for my query is absolutely fantastic and brilliant, my query is solved with the great efforts by you. What I am requesting is for further Data Report as I have to deal with the same file for different work.

Sir, whenever you have time, please try to solve my this issue.

Thanks a Ton.....