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.

 

[iazeemkhan]

Dear Sir,

You can change Sheet names as s per your convenient, I can move them. Please consider post 49 if possible.

Thanks a lot Sir.

 

[Peter_SSs]

Please consider post 49 if possible.

I did consider post 49 before I made post 50.

Have you considered my question in post 50?

.. have you tried the code after swapping each Sheet1 for Sheet2 and vice-versa?

 

[iazeemkhan]

Dear Sir,

I am sorry for delay as I was not well for last few days and missed the work.

Yes, I tried by swapping them, but its not working Sir.

Sir, request you to please ignore my other post and consider post 49 as fresh.

I am hopful.

Thanking you Sir.

 

[Peter_SSs]

Sir, request you to please ignore my other post and consider post 49 as fresh.

With layout as per post 49, I just swapped Sheet1 and Sheet2 names in the code from post 48 and it worked for me

Sub Components()
  Dim RX As Object
  Dim aResults As Variant
  Dim c As Long, i As Long, ubaResults As Long
  Dim sComp As String
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Ignorecase = True
'  <del>With Worksheets("Sheet2")</del>
  With Worksheets("Sheet1")
    aResults = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2).Value
  End With
  ubaResults = UBound(aResults)
'  <del>With Sheets("Sheet1")</del>
  With Sheets("Sheet2")
    For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
      sComp = .Cells(1, c).Value
      RX.Pattern = "\b" & Join(Application.Transpose(.Range(.Cells(2, c), .Cells(.Rows.Count, c).End(xlUp))), "|") & "\b"
      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
    Next c
  End With
'  <del>Sheets("Sheet2").Range("A2:B2").Resize(ubaResults).Value = aResults</del>
  Sheets("Sheet1").Range("A2:B2").Resize(ubaResults).Value = aResults
End Sub

 

[iazeemkhan]

Dear Sir,

Its working fantastic Sir.

Only concern is, if formula dont find any Item in Description (Sheet1) the result will be Blank.

But here if formula dont find any Item in Description (Sheet1) its display the Component name from (Sheet2) under which no Item name mentioned.

Or Say

Any Component (Sheet2) which dont have any Item under its row then also its returning Heading (Component Name) in the Result column.

Below are Images of Sheet1 and Sheet2

https://www.pastepic.xyz/image/sheet1.R4Bbp
https://www.pastepic.xyz/image/sheet2.R4Uom

Sheet1
Result are showing ATS where instead of Blank because in Sheet2 under the heading ATS, No Items are there.

Please advice

Thanking you Sir.

 

[iazeemkhan]

Dear Sir,

One more thing, How can I run this formula without going into F11 / Run? is there any other way to get the result?

Thanks a Lot Sir.

 

[iazeemkhan]

Dear Sir,

Can you please let me know the Range for both the sheets you have taken?

Thanks a Lot Sir.

 

[Peter_SSs]

Only concern is, if formula dont find any Item in Description (Sheet1) the result will be Blank.

But here if formula dont find any Item in Description (Sheet1) its display the Component name from (Sheet2) under which no Item name mentioned.

You didn't previously give any sample data like that so there was no reason for me to think that might happen. Remember I cannot see your actual workbook so I only know what you tell me or show me.

Try this version.

Sub Components_v2()
  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")
    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 = "\b" & .Cells(lr, c).Value & "\b"
        Else
          RX.Pattern = "\b" & Join(Application.Transpose(.Range(.Cells(2, c), .Cells(.Rows.Count, c).End(xlUp))), "|") & "\b"
        End If
        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

One more thing, How can I run this formula without going into F11 / Run? is there any other way to get the result?

There are many ways to run a macro. I suggest that you Google something like "Excel ways to run a macro"

Can you please let me know the Range for both the sheets you have taken?

I Sheet1 my code uses the range in column A from cell A2 down to the last row in column A that contains data.

I Sheet2 my code uses
- data in Cell A1 down to the last row in column A that contains data and then
- data in Cell B1 down to the last row in column B that contains data and then
- data in Cell C1 down to the last row in column C that contains data and then ..
.. keeps going to the last column that has any data in row 1

 

[iazeemkhan]

Dear Sir,

Many many thanks for all your cooperation, I am grateful to you forever. Its working properly as per provided data, I will check with full data and confirm you soon.

Once again Thanks a lot Sir.

 

[Peter_SSs]

Its working properly as per provided data,

Good to hear.