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,

Thanks for your cooperation Sir, yes i will make sure that question will not be reapeated. Many many thanks for your messages. Have a great day Sir,

Waiting for oyur kind reply on last message

I remian.

Best Regards,

 

[iazeemkhan]

Dear Sir,

Actually, I am little nervous and wanted to get the Answer as early as possible. As I am little aware of the forum rules, I will take a very close look and act accordingly hereafter, Sir, hope you will accept my apology. I Apologies Sir.

And lookling forward for your expert comment and advice for my last query Psot #78 .

Sir, please request you to ignore my mistake.

I remain.

Best regards

 

[Peter_SSs]

If it is possible that more than 1 Item can appear in the Description, what is to happen if the Items listed in the Description come from 2 or more different Components?

For example

Excel Workbook
	A	B
1	Component 1	Component 2
2	Item 1	Item 4
3	Item 2	Item 5
4	Item 3	Item 2
Sheet2

What would go in B2:C3 below?

Excel Workbook
	A	B	C
1	Description	Component	Items
2	This contains Item 1 and Item 2 and Item 6	??	??
3	This contains Item 3 and Item 4	??	??
Sheet1

 

[iazeemkhan]

Dear Sir,

Item will not be repeated in any other Component. All the components will have their unique ITEMs and will not be repeat in other Component.

Best regards.

 

[iazeemkhan]

Dear Sir,

I got your point Sir, I will revert you as soon as possible as I have to consult and get the final opinion as what exactly needed.

Thanking you Sir,

Best regrads.

 

[iazeemkhan]

Dear Sir,

I am extreamly sorry for delay in reply as the concern person was not available. I am very much thankful to you for your coperation Sir.

Reply below;

	A	B
1	Component 1	Component 2
2	Item 1	Item 4
3	Item 2	Item 5
4	Item 3	Item 2

<tbody>
</tbody>

What would go in B2:C3 below?

Sheet1

	A	B	C
1	Description	Component	Items
2	This contains Item 1 and Item 2 and Item 6	Component 1	Item 1,Item 2
3	This contains Item 3 and Item 4	Component 1	Item 3, Item 4

<tbody>
</tbody>

Sir, basically, description will have a content which guide us to further process for finding the Components and in your example Item 3 and Item 4 are from different Components, which is unique and very nicely pointed out.

Sir, at the outset, Description will not have Items from different Components and if its contain for any reason then whichever Item comes First "First Item found in Description and return its Component Name (But in Item Column "C" we will add those Item names with comma. example above).


Thank you very much Sir,

 

[iazeemkhan]

Dear Sir,

Hope you are in Sound health. Just worried about your absence since days.

Take care Sir.

Best Wishes

 

[iazeemkhan]

Dear Sir,

Is everything OK? Please take care.

 

[iazeemkhan]

Dear Sir,

How are you? Sir, please request you to see the Post #86 as my reply to your query of Post #83 . Take care,

Have a great time.

Best regards

 

[Peter_SSs]

Dear Sir,

Is everything OK? Please take care.

I'm fine thanks - just been away for a while.

I don't think getting the results you posted for cell C3 in post 86 is feasible, or worth the effort trying since you have stated that it is unlikely that Items from more than 1 Component will be found in any Description. Therefore, with the sample data from post 83 the code below will only return 'Item 3' in cell C3. That is, the code will list all the Items found in the Description from the first Component identified only.

Sub Components_v5()
  Dim RX As Object
  Dim aResults As Variant, itm As Variant
  Dim c As Long, i As Long, ubaResults As Long, lr As Long
  Dim sComp As String, sItems As String
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  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
              sItems = vbNullString
              For Each itm In RX.Execute(aResults(i, 1))
                sItems = sItems & ", " & itm
              Next itm
              aResults(i, 3) = Mid(sItems, 3)
            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