Keyword Search to Pull Data From Different Worksheet and Place Cell Value Into Cell

[stevenao13]

I’m trying to create a macro that will search for certain “keywords” from C9 down to the end of the printable area, since the area grows if new rows are added, or to where there is no more data in the B&C columns (whichever is easier to code). I want the cell in the next column (D) that had a keyword hit in column (C) to pull data from a group I’ve named “Recommendation” on another sheet in the same workbook.

Keywords will change for each “Recommendation”, so I will have to place multiple keywords for each “Recommendation” and will have to do this for all items in the “Recommendation” range. This is why I cannot do a formula, as there are 65 items right now and will continue to grow.

Right now I’m using a pull down menu with Data Validation, but hope I can automate to look for the keywords and add these quicker.

The one I started only pulls the data and place it into column D if column C is empty and cannot figure out why it doesn’t see the TXT as a keyword.

Inspection Findings Sheet

A	B	C	D	E
#	Workplace	Finding	Recommendation	Risk
1	DFW RTR	Fluorescent lamps not guarded
2	DFW ASR	No lockout tagout procedures

<tbody>
</tbody>

Recommendations Reference Sheet

Recommendation	Keyword
Install protective guards against accidental contact	lamps, covered
Use new LOTO templates	lockout tagout, procedures

<tbody>
</tbody>

My crude coding:

Sub Auto_Fill()
    Application.ScreenUpdating = False
Dim x As Long


For x = 9 To ActiveSheet.UsedRange.Rows.Count
    If Cells(x, 3) = (Txt = "*lamps") Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(51, 1)
            End If
Next x


End Sub

Any help is greatly appreciated. I’ve done minor macros from what I’ve learned on here before and this one is just way above what I know currently or tried searching for days on the fix.

 

[pfedorov]

are there several keywords in one cell? should the recommendation be populated based on matching any ONE keyword or ALL of them? Is it possible that keywords are the same for more than one recommendation? If so, how would you like it to be handled?

 

[stevenao13]

Thank you for responding. I'm not the best at being descriptive of what I want since this is a little tricky for me to put in words, but I'll do my best and I'll use images to help.

There can be several keywords in a cell. Almost always the keywords will be different for each recommendation. It would be helpful if it can include multiple keywords, but if it can hit one, that should suffice.

On the Inspection Findings Sheet, I want the macro to search only column C and start searching at column C9 (see examples in images), and look for keywords listed on the Recommendation Sheet (these keywords can be inside the code in the macro) as I don't know which is easier to have the keywords in the code or have the macro compare against the list of keywords in the cells on the Recommendation sheet, which I think would be harder, but I'll leave that up to anyone willing to help. These keywords are what are to be looked for in the "Findings" column on the Inspection Findings Sheet.

Search area



Recommendation Data Cells and Keywords


Flow - So hear you see that cell C14 had "emergency light" in it and it should place data from "Recommendation sheet" cell A3 into cell D14 (see finished image at the end)


Finished Product



I hope this makes more sense. Again, thank you for helping me out.

 

[stevenao13]

So here's my updated code. But it only sees lamps if that is the only word in the cell. How can I get it to search for that keyword in a sentence in the cell?

Sub Auto_Fill()    Application.ScreenUpdating = False
Dim x As Long


For x = 9 To ActiveSheet.UsedRange.Rows.Count
    If Cells(x, 3).Value = "lamps" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(51, 1)
            End If
Next x
Application.ScreenUpdating = True
End Sub

 

[stevenao13]

I'm on the right track, but have stumbled upon something else I cannot figure out. I was able to get this code to find one keyword and pull the data from the other sheet like I wanted, however I would like to be able to have multiple keywords required to pull the data. It will not see the word if the first word is capitalized also.

Sub Auto_Fill()

Application.ScreenUpdating = False
Dim x As Long




For x = 9 To ActiveSheet.UsedRange.Rows.Count
    If Cells(x, 3).Value Like "*lamp*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(51, 1)
    Else
    If Cells(x, 3).Value Like "*knockout*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(11, 1)
    Else
    If Cells(x, 3).Value Like "*attery backup*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(3, 1)
    Else
    If Cells(x, 3).Value Like "*disconnect*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(9, 1)
            End If
            End If
            End If
            End If
Next x
Application.ScreenUpdating = True


End Sub

 

[rmfrase]

I'm on the right track, but have stumbled upon something else I cannot figure out. I was able to get this code to find one keyword and pull the data from the other sheet like I wanted, however I would like to be able to have multiple keywords required to pull the data. It will not see the word if the first word is capitalized also.

Sub Auto_Fill()

Application.ScreenUpdating = False
Dim x As Long




For x = 9 To ActiveSheet.UsedRange.Rows.Count
    If Cells(x, 3).Value Like "*lamp*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(51, 1)
    Else
    If Cells(x, 3).Value Like "*knockout*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(11, 1)
    Else
    If Cells(x, 3).Value Like "*attery backup*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(3, 1)
    Else
    If Cells(x, 3).Value Like "*disconnect*" Then
            Cells(x, 4).Value = ThisWorkbook.Worksheets("Recommendations Reference").Cells(9, 1)
            End If
            End If
            End If
            End If
Next x
Application.ScreenUpdating = True


End Sub

Try this:
Be sure your keywords use correct upper/lower case.

Sub Auto_Fill()

Application.ScreenUpdating = False
Dim x As Long

For x = 9 To ActiveSheet.UsedRange.Rows.Count
    Cells(x, 2).Select
    If Cells(x, 2).Value Like "*lamp*" Then
            Cells(x, 3).Value = Worksheets("Recommendations Reference").Cells(15, 1)
    Else
    If Cells(x, 2).Value Like "*Knockout*" Then
            Cells(x, 3).Value = Worksheets("Recommendations Reference").Cells(11, 1)
    Else
    If Cells(x, 2).Value Like "*attery backup*" Then
            Cells(x, 3).Value = Worksheets("Recommendations Reference").Cells(3, 1)
    Else
    If Cells(x, 2).Value Like "*Disconnect*" Then
            Cells(x, 3).Value = Worksheets("Recommendations Reference").Cells(9, 1)
            End If
            End If
            End If
            End If
Next x
End Sub

 

[pfedorov]

Steven,

The following code should populate the recommendations based on INDIVIDUAL keywords. The following is the link for my mock workbook. There are limitations with this code: If any ONE word matches then the recommendation will be populated. If you can find a way to standardize your FINDINGS and KEYWORDS so a match would be more unique then I highly recommend you do that, because matching based on several words makes the code MUCH more complex. Please test out what you see here; hopefully it'll be helpful.

https://onedrive.live.com/redir?page=view&resid=D91C36B074F4D0F6!3210&authkey=!ADgMey5oE9Po3tE


Sub KeywordRecommendation()

k = 2

For Each cell In ActiveWorkbook.Sheets("INSPECTION FINDINGS").Range("C2:C6") 'extend range as necessary
FindingKeyWords = Split(cell, " ") 'breaks down words in finding cells seperated by spaces
For Z = 2 To 10 'extend range as necessary
'the following line of code breaks down words in keyword cells seperated by ", "
RecKeyword = Split(ActiveWorkbook.Sheets("Recommendations Reference").Cells(Z, 2).Value, ", ")

'the following two loops test individual words from Finding cells against Keyword cells
For i = 0 To UBound(FindingKeyWords)
For j = 0 To UBound(RecKeyword)
If FindingKeyWords(i) = RecKeyword(j) Then
Cells(k, 4) = ActiveWorkbook.Sheets("Recommendations Reference").Cells(Z, 1)
'if ANY words match then respective recommendation will be copied to the INSPECTION FINDINGS sheet
End If
Next j
Next i

Next Z
k = k + 1
Next cell

End Sub