vba to copy text to cells based on text in another cell

[cjcass]

Hi,

I'm looking for some vba that will do the following:

I have cells in Sheet1 from cell J101 down (the last cell is variable) that contain text as phrases/sentences.

I have a table in Sheet2 M6:O100. In column M each cell has a keyword in it (eg. dog). Next to each keyword in adjacent cells there are some words in column N (eg. favourite pet) and O (eg. black and white). The table can vary in rows down, ie. it might only have text in cells M6:O30.

I'm looking for some vba that will look at all the phrases/sentences in Sheet1 J101:J### and where it finds a keyword in the phrase (from Sheet2 M6:M##) it populates the corresponding cells in Sheet1 columns E&F with the corresponding words from the cells in Sheet2 N6:O##. The words in the phrases will vary in terms of their case, so cases should not be matched during the vba's search.

So, if Sheet1 cell J175 contains the phrase 'I always walk my dog on Friday' the vba will put 'favourite pet' into cell E175 and 'black and white' into cell F175.
In the event that there are two keywords present in a phrase then it should return the next set of words into cells G175 & H175. After that it should stop. So, if there are three or more keywords it should just return text for the first two found.

Hope this makes sense.
Any help much appreciated.

 

[cjcass]

That is not correct. Here is an example: Index Match multiple results skip the blanks

Ok, here goes - the 2 sheets pasted in here relate to the text in this post.
The last section of phrases and entries in Sheet1 E116:J119 have been written in such a way to test the solution against the peculiarities I put in bullets earlier in the post.
Please note that the headers above the tables (text1, text2 etc.) are not present in my own file, they have been put in this sample just for reference, my tables don't have headers.
Hope my XL2BB sheets work and the brief is clear enough.

Book1.xlsx
	D	E	F	G	H	I	J	K
99
100		text1	text2	text1	text2		phrase
101		Favourite pet	Black & white				the dog walks down the road
102		Eyes	Ears				the cat sits on the fence
103							how many apples
104		Fast	Steam & Oil	Dark	Scarlet		I like the train and carriage in red
105							there's not enough space in my garden
106							it's the best place around here
107		Girlfriend					what do you mean??
108							"It's not funny anymore!"
109							sixty five benches
110							£10,000 would be great
111		Favourite pet	Black & white				I love my DOG
112		Eyes	Ears	Favourite pet	Black & white		the cat and the dog sit on the grass
113							the bus is late
114		Treetops					the car is so slow
115							thecat ate the dog's dinner
116		Eyes	Ears	Favourite pet	Black & white		the cat and the dog got hit by a train
117		Snow	Mobile	Favourite pet	Black & white		I love my DOG and the cat
118		Salesman		Dark	Scarlet		My favourite red coat
119		Tree		Car			I love my Dog
120
121
122
Sheet1

Book1.xlsx
	L	M	N	O	P
3
4
5		keyword	text1	text2
6		Dog	Favourite pet	Black & white
7		Cat	Eyes	Ears
8		Train	Fast	Steam & Oil
9		Funny	Haha	Clown
10		Red	Dark	Scarlet
11
12
13
14
15
16
17
Sheet2

 

[Peter_SSs]

Thanks for the XL2BB samples.

1. Is the order of results important? For example, in this result ..

.. would it matter if the result was instead?
Favourite pet | Black & white | Eyes | Ears

2. Does it have to be vba? At least a reasonable approximation (if order does not matter) could be achieved with formulas. Punctuation may cause a problem with this approach (& may also make any vba approach trickier too since I assume that you are looking for whole words and so would not want keyword "cat" to trigger with "My dog scattered the geese"?)

cjcass.xlsm
	G	H	I	J	K	L
100	text1	text2	text1	text2		phrase
101	Favourite pet	Black & white				the dog walks down the road
102	Eyes	Ears				the cat sits on the fence
103						how many apples
104	Fast	Steam & Oil	Dark	Scarlet		I like the train and carriage in red
105						there's not enough space in my garden
106						it's the best place around here
107						what do you mean??
108	Haha	Clown				"It's not funny anymore!"
109						sixty five benches
110						£10,000 would be great
111	Favourite pet	Black & white				I love my DOG
112	Favourite pet	Black & white	Eyes	Ears		the cat and the dog sit on the grass
113						the bus is late
114						the car is so slow
115						thecat ate the dog's dinner
116	Favourite pet	Black & white	Eyes	Ears		the cat and the dog got hit by a train
117	Favourite pet	Black & white	Eyes	Ears		I love my DOG and the cat
118	Dark	Scarlet				My favourite red coat
119	Favourite pet	Black & white				I love my Dog
Sheet1

Cell Formulas
Range	Formula
G101:H119	G101	=IFERROR(INDEX(Sheet2!N:N,AGGREGATE(15,6,ROW(Sheet2!N$6:N$12)/ISNUMBER(SEARCH(" "&Sheet2!$M$6:$M$100&" "," "&$L101&" ")),1))&"","")
I101:J119	I101	=IFERROR(INDEX(Sheet2!N:N,AGGREGATE(15,6,ROW(Sheet2!N$6:N$12)/ISNUMBER(SEARCH(" "&Sheet2!$M$6:$M$100&" "," "&$L101&" ")),2))&"","")

 

[cjcass]

Thanks for the XL2BB samples.

1. Is the order of results important? For example, in this result ..
View attachment 63776
.. would it matter if the result was instead?
Favourite pet | Black & white | Eyes | Ears

2. Does it have to be vba? At least a reasonable approximation (if order does not matter) could be achieved with formulas. Punctuation may cause a problem with this approach (& may also make any vba approach trickier too since I assume that you are looking for whole words and so would not want keyword "cat" to trigger with "My dog scattered the geese"?)

cjcass.xlsm
	G	H	I	J	K	L
100	text1	text2	text1	text2		phrase
101	Favourite pet	Black & white				the dog walks down the road
102	Eyes	Ears				the cat sits on the fence
103						how many apples
104	Fast	Steam & Oil	Dark	Scarlet		I like the train and carriage in red
105						there's not enough space in my garden
106						it's the best place around here
107						what do you mean??
108	Haha	Clown				"It's not funny anymore!"
109						sixty five benches
110						£10,000 would be great
111	Favourite pet	Black & white				I love my DOG
112	Favourite pet	Black & white	Eyes	Ears		the cat and the dog sit on the grass
113						the bus is late
114						the car is so slow
115						thecat ate the dog's dinner
116	Favourite pet	Black & white	Eyes	Ears		the cat and the dog got hit by a train
117	Favourite pet	Black & white	Eyes	Ears		I love my DOG and the cat
118	Dark	Scarlet				My favourite red coat
119	Favourite pet	Black & white				I love my Dog
Sheet1

Cell Formulas
Range	Formula
G101:H119	G101	=IFERROR(INDEX(Sheet2!N:N,AGGREGATE(15,6,ROW(Sheet2!N$6:N$12)/ISNUMBER(SEARCH(" "&Sheet2!$M$6:$M$100&" "," "&$L101&" ")),1))&"","")
I101:J119	I101	=IFERROR(INDEX(Sheet2!N:N,AGGREGATE(15,6,ROW(Sheet2!N$6:N$12)/ISNUMBER(SEARCH(" "&Sheet2!$M$6:$M$100&" "," "&$L101&" ")),2))&"","")

Hi,
Many thanks for your time on this, in response to your questions/solution:
1. The order of the result is not important, ie. the dog entry could come before the cat or vice versa, so long as the entries are paired correctly and in the right order, ie. the Eyes comes before the Ears and they are together.
2. Yes, you are correct, I would not want keyword "cat" to trigger with "My dog scattered the geese.
3. Punctuation is not an issue, so cat could trigger with cat, cat! cat; cat.
4. It doesn't have to be vba, I just assumed that the complexity of the requirement may dictate a vba solution.
5. Looking at your solution output above in rows 117:119; the solution has overriden the text that is already in place (ie. Snow, Mobile, Salesman, Tree and Car) and I was hoping that they would remain in place (I probably didn't explain this clearly). This is because the formulas are written directly into the cells. I guess I could get over this with an interim helper table that looks to see if the cells are empty first... IF(Sheet1!G117="",etc.. and then transfer the result across.
Regards.

 

[Peter_SSs]

3. Punctuation is not an issue, so cat could trigger with cat, cat! cat; cat.

Actually, that means that punctuation is an issue. Since scattered should not be triggered by cat, we are looking for whole words. The most common, simple way to do that is to look at text between spaces but punctuation easily messes that up. eg "I have a cat, dog and mouse". Using the 'between spaces' theory the word "cat" does not appear in that text.

However, we may still be able to achieve something with vba.

the solution has overriden the text that is already in place (ie. Snow, Mobile, Salesman, Tree and Car)

I was wondering about those and figured that maybe you had just forgotten to remove them from your sample.
Is it possible that any row that has pre-existing text like that might also have one or more keywords?
If so and it was the "Girlfriend" row would the keyword data just go in the green columns? And if it was the tree/car row no keyword data would get added?

 

[cjcass]

Actually, that means that punctuation is an issue. Since scattered should not be triggered by cat, we are looking for whole words. The most common, simple way to do that is to look at text between spaces but punctuation easily messes that up. eg "I have a cat, dog and mouse". Using the 'between spaces' theory the word "cat" does not appear in that text.

However, we may still be able to achieve something with vba.


I was wondering about those and figured that maybe you had just forgotten to remove them from your sample.
Is it possible that any row that has pre-existing text like that might also have one or more keywords?
If so and it was the "Girlfriend" row would the keyword data just go in the green columns? And if it was the tree/car row no keyword data would get added?

After I replied re. the punctuation I realised that was an issue with the formulas and have been hunting online for some vba that will remove punctuation temporarily in a helper table so the formulas would work and then transfer the solution data into the main table where the punctuation in the phrases will still be intact.

Regarding keywords being present in the mix of pre-exisitng words in Sheet1, the answer is yes they will definitely be present.

Rgds.

 

[cjcass]

Actually, that means that punctuation is an issue. Since scattered should not be triggered by cat, we are looking for whole words. The most common, simple way to do that is to look at text between spaces but punctuation easily messes that up. eg "I have a cat, dog and mouse". Using the 'between spaces' theory the word "cat" does not appear in that text.

However, we may still be able to achieve something with vba.


I was wondering about those and figured that maybe you had just forgotten to remove them from your sample.
Is it possible that any row that has pre-existing text like that might also have one or more keywords?
If so and it was the "Girlfriend" row would the keyword data just go in the green columns? And if it was the tree/car row no keyword data would get added?

Sorry, forgot to respond to your last question - yes... the "Girlfriend" row would have the keyword data just go in the green columns, and if it was the tree/car row no keyword data would get added.

 

[Peter_SSs]

I have not tried to do a lot regarding punctuation (yet) but wanted to see how this goes first.
Seems to me to be fine for the sample data from post #11.
Test with a copy.

Sub KeywordLookup()
  Dim d As Object, RX As Object, M As Object
  Dim a As Variant
  Dim i As Long, oSet As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.Comparemode = 1
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  With Sheets("Sheet2")
    a = .Range("M6", .Range("O" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = a(i, 2) & "|" & a(i, 3)
  Next i
  RX.Pattern = "\b(" & Join(d.Keys(), "|") & ")\b"
  With Sheets("Sheet1")
    With .Range("L101", .Range("L" & Rows.Count).End(xlUp))
      a = .Value
      For i = 1 To UBound(a)
        oSet = 0
        If IsEmpty(.Cells(i).Offset(, -5).Value) Then
          oSet = -5
        ElseIf IsEmpty(.Cells(i).Offset(, -3).Value) Then
          oSet = -3
        End If
        If oSet < 0 Then
          If RX.test(a(i, 1)) Then
            Set M = RX.Execute(a(i, 1))
            .Cells(i).Offset(, oSet).Resize(, 2).Value = Split(d(CStr(M(0))), "|")
            If oSet = -5 And M.Count > 1 Then .Cells(i).Offset(, oSet + 2).Resize(, 2).Value = Split(d(CStr(M(1))), "|")
          End If
        End If
      Next i
    End With
  End With
End Sub

 

[cjcass]

I have not tried to do a lot regarding punctuation (yet) but wanted to see how this goes first.
Seems to me to be fine for the sample data from post #11.
Test with a copy.

Sub KeywordLookup()
  Dim d As Object, RX As Object, M As Object
  Dim a As Variant
  Dim i As Long, oSet As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  d.Comparemode = 1
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  With Sheets("Sheet2")
    a = .Range("M6", .Range("O" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = a(i, 2) & "|" & a(i, 3)
  Next i
  RX.Pattern = "\b(" & Join(d.Keys(), "|") & ")\b"
  With Sheets("Sheet1")
    With .Range("L101", .Range("L" & Rows.Count).End(xlUp))
      a = .Value
      For i = 1 To UBound(a)
        oSet = 0
        If IsEmpty(.Cells(i).Offset(, -5).Value) Then
          oSet = -5
        ElseIf IsEmpty(.Cells(i).Offset(, -3).Value) Then
          oSet = -3
        End If
        If oSet < 0 Then
          If RX.test(a(i, 1)) Then
            Set M = RX.Execute(a(i, 1))
            .Cells(i).Offset(, oSet).Resize(, 2).Value = Split(d(CStr(M(0))), "|")
            If oSet = -5 And M.Count > 1 Then .Cells(i).Offset(, oSet + 2).Resize(, 2).Value = Split(d(CStr(M(1))), "|")
          End If
        End If
      Next i
    End With
  End With
End Sub

Ok so this is looking good so far.

There are a couple of fine tuning things if possible, not sure if this achievable:

1. If I run the macro twice it will put the same keyword data that's in the yellow cells into the green cells too, so if we only have 'cat' in the phrase it will put 'Eyes' & 'Ears' into the yellow cells and if I run it again it puts the same again into the green cells - I only really want a set of keyword data to appear once if the macro is run several times.

2. Also if the phrase contains the keyword 'cat' more than once (which could happen) it will populate both the yellow and green cells with 'Eyes' & 'Ears' which again is replication. I would only want it to appear once.

Apologies, I should have thought of this before but only just now realising the different permutations!!

Regards,

 

[cjcass]

I have not tried to do a lot regarding punctuation (yet) but wanted to see how this goes first.
Seems to me to be fine for the sample data from post #11.
Test with a copy.

Sub KeywordLookup()
  Dim d As Object, RX As Object, M As Object
  Dim a As Variant
  Dim i As Long, oSet As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  d.Comparemode = 1
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  With Sheets("Sheet2")
    a = .Range("M6", .Range("O" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = a(i, 2) & "|" & a(i, 3)
  Next i
  RX.Pattern = "\b(" & Join(d.Keys(), "|") & ")\b"
  With Sheets("Sheet1")
    With .Range("L101", .Range("L" & Rows.Count).End(xlUp))
      a = .Value
      For i = 1 To UBound(a)
        oSet = 0
        If IsEmpty(.Cells(i).Offset(, -5).Value) Then
          oSet = -5
        ElseIf IsEmpty(.Cells(i).Offset(, -3).Value) Then
          oSet = -3
        End If
        If oSet < 0 Then
          If RX.test(a(i, 1)) Then
            Set M = RX.Execute(a(i, 1))
            .Cells(i).Offset(, oSet).Resize(, 2).Value = Split(d(CStr(M(0))), "|")
            If oSet = -5 And M.Count > 1 Then .Cells(i).Offset(, oSet + 2).Resize(, 2).Value = Split(d(CStr(M(1))), "|")
          End If
        End If
      Next i
    End With
  End With
End Sub

A point to note if I may - your solution is now working with columns GHIJ&L in Sheet1 and the ultimate solution is going to have to work with EFGH&J in Sheet1 as per Post #11. Normally, I would be able to adjust your solution accordingly but I notice your vba is quite complex and is offsetting a lot so adjusting it may be a bit a challenge for me - is it possible to adjust it or am I missing something?

 

[Peter_SSs]

is it possible to adjust

Column adjustments will definitely be possible.

1. If I run the macro twice it will put the same keyword data that's in the yellow cells into the green cells too, so if we only have 'cat' in the phrase it will put 'Eyes' & 'Ears' into the yellow cells and if I run it again it puts the same again into the green cells - I only really want a set of keyword data to appear once if the macro is run several times.

Should be able to handle this. Do the text values in Sheet2 ever change for a particular keyword? That is, we run the code and cat will populate Eyes and Ears and you don't want that to happen again if the code is run again. But next time the code runs could cat now be "Knees" and "Toes", or "Eyes" and "Toes" or even just swapped to "Ears" and "Eyes". If any change for a particular keyword between runs is possible, can you explain what should happen on the second run?

2. Also if the phrase contains the keyword 'cat' more than once (which could happen) it will populate both the yellow and green cells with 'Eyes' & 'Ears' which again is replication. I would only want it to appear once.

Should be able to handle that.

I can't look closely at it just now but hopefully in the next day or so & should have an answer to the above by then with a bit of luck.