Checking long string for list of keywords and extracting only the keyword if exists

[WednesdayC]

Hi Team

Can anyone help me please?

I have a long string in column A.

What I am trying to do is check for a list of words (need wildcards) (the word or words will only appear (if at all) once) and if the word(s) exists, copy that word to a separate column, say B.

So check for say, "book", "petrol", "coffee", "mobile phone" in the cell in column A, and if, say "mobile phone" exists anywhere in the cell, add the wording "mobile phone" to the adjacent cell in column B.

I am really stuck on this.

A huge thanks if anyone has a solution.

Regards

Wednesday

 

[alansidman]

Re: Help with checing long string for list of keywords and extracting only the keyword if exists

Option Explicit


Sub findWords()
    Dim i As Long, lr As Long
    Dim crit1 As String, crit2 As String, crit3 As String, crit4 As String
    crit1 = "book": crit2 = "petrol": crit3 = "coffee": crit4 = "mobile phone"
    lr = Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To lr
        If InStr(Range("A" & i), crit1) > 0 Then
            Range("B" & i) = crit1
        ElseIf InStr(Range("A" & i), crit2) > 0 Then
            Range("B" & i) = crit2
        ElseIf InStr(Range("A" & i), crit3) > 0 Then
            Range("B" & i) = crit3
        ElseIf InStr(Range("A" & i), crit4) > 0 Then
            Range("B" & i) = crit4
        End If
    Next i
    Application.ScreenUpdating = True


End Sub

 

[kweaver]

Re: Help with checing long string for list of keywords and extracting only the keyword if exists

There probably is a slicker way to do this, but I always look for a solution that works first.
I put the words to search for in column C.

Sub FindWords()
Dim LR As Long, pos As String, i As Integer
LR = Cells(Rows.Count, "C").End(xlUp).Row
pos = ""
For i = 1 To LR
If InStr(1, Range("A1"), Range("C" & i), vbBinaryCompare) > 0 Then
  pos = pos & ", " & Range("C" & i)
Else
End If
Next i
Cells(1, 2) = Right(pos, Len(pos) - 2)
End Sub

 

[dmt32]

Re: Help with checing long string for list of keywords and extracting only the keyword if exists

Hi,
Range.Find method may do what you want

Sub FindMatchingWords()
    
    Dim arr As Variant
    Dim foundcell As Range
    Dim firstAddress As String
    Dim i As Integer
    
    arr = Array("book", "petrol", "coffee", "mobile phone")
    
    With Worksheets("Sheet1").Columns(1)
        For i = LBound(arr) To UBound(arr)
'find first match
            Set foundcell = .Find(What:=arr(i), LookAt:=xlPart, LookIn:=xlValues)
            
            If Not foundcell Is Nothing Then
'search for other matches
                firstAddress = foundcell.Address
                Do
                    foundcell.Offset(, 1).Value = arr(i)
                    
                    Set foundcell = .FindNext(foundcell)
                    
                Loop While foundcell.Address <> firstAddress
            End If
            Set foundcell = Nothing
        Next i
    End With
End Sub

Dave

 

[WednesdayC]

Re: Help with checing long string for list of keywords and extracting only the keyword if exists

Hi Alan

Thank you very much for your reply.

The actual list of words is much longer than specified. I should have been more specific - sorry about that. Can I have as many criteria as I like and if so I presume it would be better to use select case?

Sorry but I won't have time to test this until later today and will get back to you.

Once again thank you

Wednesday

 

[WednesdayC]

Re: Help with checing long string for list of keywords and extracting only the keyword if exists

Hi dmt32

Thanks very much for your reply.

I will try this option a bit later, as it looks like this will be easier, as the string of words is quite long - about 16.

Will confirm if works later

Regards

Wednesday

 

[WednesdayC]

Re: Help with checing long string for list of keywords and extracting only the keyword if exists

Hi KWeaver

Thanks a lot but I don't think vbBinaryCompare works with Excel for Mac.

Will check later in case.

Regards

Wednesday