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]

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?

No, the keyword text values in Sheet2 won't change in between macro runs.

 

[cjcass]

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.

Ok that's great, thanks for your help so far

 

[Peter_SSs]

Let's see if this handles the various issues raised. If there is still some problems (quite likely) then please post some small sample data that demonstrates, and give explanation in relation to that sample data.

Sub KeywordLookup_v2()
  Dim d As Object, dM As Object, RX As Object
  Dim a As Variant, itm As Variant
  Dim i As Long, rw As Long, BaseRw As Long
  Dim PhraseRange As Range
  Dim OppSide As String
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  Set dM = CreateObject("Scripting.Dictionary")
  dM.CompareMode = 1
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  a = Sheets("Sheet2").Range("M6", Sheets("Sheet2").Range("O" & Rows.Count).End(xlUp)).Value
  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"
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    Set PhraseRange = .Range("J101", .Range("J" & Rows.Count).End(xlUp))
    BaseRw = PhraseRange.Row - 1
    a = PhraseRange.Value
    For i = 1 To UBound(a)
      dM.RemoveAll
      For Each itm In RX.Execute(a(i, 1))
        dM(CStr(itm)) = d(CStr(itm))
      Next itm
      rw = BaseRw + i
      
      If IsEmpty(.Range("E" & rw).Value) Then
        OppSide = .Range("G" & rw).Value & "|" & .Range("H" & rw).Value
        Do Until Not IsEmpty(.Range("E" & rw).Value) Or dM.Count = 0
          If dM.Items()(0) <> OppSide Then .Range("E" & rw).Resize(, 2) = Split(dM.Items()(0), "|")
          dM.Remove dM.Keys()(0)
        Loop
      End If
        
      If IsEmpty(.Range("G" & rw).Value) Then
        OppSide = .Range("E" & rw).Value & "|" & .Range("F" & rw).Value
        Do Until Not IsEmpty(.Range("G" & rw).Value) Or dM.Count = 0
          If dM.Items()(0) <> OppSide Then .Range("G" & rw).Resize(, 2) = Split(dM.Items()(0), "|")
          dM.Remove dM.Keys()(0)
        Loop
      End If
      
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

 

[cjcass]

Let's see if this handles the various issues raised. If there is still some problems (quite likely) then please post some small sample data that demonstrates, and give explanation in relation to that sample data.

Sub KeywordLookup_v2()
  Dim d As Object, dM As Object, RX As Object
  Dim a As Variant, itm As Variant
  Dim i As Long, rw As Long, BaseRw As Long
  Dim PhraseRange As Range
  Dim OppSide As String
 
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  Set dM = CreateObject("Scripting.Dictionary")
  dM.CompareMode = 1
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  a = Sheets("Sheet2").Range("M6", Sheets("Sheet2").Range("O" & Rows.Count).End(xlUp)).Value
  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"
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
    Set PhraseRange = .Range("J101", .Range("J" & Rows.Count).End(xlUp))
    BaseRw = PhraseRange.Row - 1
    a = PhraseRange.Value
    For i = 1 To UBound(a)
      dM.RemoveAll
      For Each itm In RX.Execute(a(i, 1))
        dM(CStr(itm)) = d(CStr(itm))
      Next itm
      rw = BaseRw + i
     
      If IsEmpty(.Range("E" & rw).Value) Then
        OppSide = .Range("G" & rw).Value & "|" & .Range("H" & rw).Value
        Do Until Not IsEmpty(.Range("E" & rw).Value) Or dM.Count = 0
          If dM.Items()(0) <> OppSide Then .Range("E" & rw).Resize(, 2) = Split(dM.Items()(0), "|")
          dM.Remove dM.Keys()(0)
        Loop
      End If
       
      If IsEmpty(.Range("G" & rw).Value) Then
        OppSide = .Range("E" & rw).Value & "|" & .Range("F" & rw).Value
        Do Until Not IsEmpty(.Range("G" & rw).Value) Or dM.Count = 0
          If dM.Items()(0) <> OppSide Then .Range("G" & rw).Resize(, 2) = Split(dM.Items()(0), "|")
          dM.Remove dM.Keys()(0)
        Loop
      End If
     
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

Hi, many thanks for this, I'm pretty flat out today so may not be able get to it immediately, but I will definitely come back to you soon

 

[Peter_SSs]

Hi, many thanks for this, I'm pretty flat out today so may not be able get to it immediately, but I will definitely come back to you soon

No problem - when you are ready.

 

[cjcass]

No problem - when you are ready.

Hi,
Sorry for the delay in coming back, it's been pretty full on the last couple of days!
I've been putting this to the test and it works brilliantly, it's robust and is exactly what I need - I've been trying lots of different phrases and I can't fault it!!
If I do find anything I'll let you know but it's working a treat.
Many thanks indeed for the solution and all your time, much appreciated
Best Regards.

 

[Peter_SSs]

You're welcome. Glad it is working for you. Thanks for the follow-up.

 

[cjcass]

You're welcome. Glad it is working for you. Thanks for the follow-up.

Hi Peter_SSs,

I have a follow up query / request re. this project as I've now been using your code everyday since you developed it for me and have spotted something that would of great benefit if it's achievable, not sure if you're able to help with it?

I have been using more than one word for some keywords and your code deals with it well, but I was wondering if the following is achievable:

I have the following keywords:

1. health
2. care
3. healthcare
4. health care

Your code deals with the first 3 no problem, but the 4th is obviously outside of the code's capability because it wasn't part of the requirements that were set - the code will currently read either 'health' or 'care'. Is it possible that the code could be adapated so that it would recognise 'health care' when these two words are sequential in this way, without affecting the first 3 keywords in any way?

Apologies that this wasn't part of the initial brief but I've only uncovered this as I've been using the code extensively.

Any help much appreciated.
Rgds,

 

[Peter_SSs]

I don't have time to investigate right now but try putting 'health care' above the others in the Sheet2 keyword list.
If that is still no good then please give small sample data that shows the problem, explain what results you are currently getting for that data and what results you want to get for that data.

 

[cjcass]

I don't have time to investigate right now but try putting 'health care' above the others in the Sheet2 keyword list.
If that is still no good then please give small sample data that shows the problem, explain what results you are currently getting for that data and what results you want to get for that data.

Putting 'health care' above the rest works perfectly, many thanks for the direction and help again