Problem with too many identical loops

[archer]

Hi,
I'm required to write a simple code at work on Excel. I'm familiar with C++ but completely new with VBA so I have this problem.

I'm writing a bit of code that search a record using a keyword and if found, it will put a work category next to that records. E.g. if there is a word 'drainage' in the record then I know the work type would be 'drainange repair'.

I have the code working ok, but the problem is when I have a few keywords, I have to run the loop everytime and consider the number of re cords I have, it will take ages. Is there anyone that could help me make the code in one loop or is there any other way?

I really appreciate your help
Thanks


Function ExactWordInString(Text As String, Word As String, Worktype As String) As String
ExactWordInString = " " & UCase(Text) & " " Like "*[!A-Z]" & UCase(Word) & "[!A-Z]*"
If (ExactWordInString = True) Then
ExactWordInString = Worktype
Else
ExactWordInString = Empty
End If
End Function

Sub find()
'find last row(for loop)
Dim lastrow As Integer
lastrow = Range("A" & Rows.Count).End(xlUp).Row

'first loop that using the first keyword at R2C2
Dim i As Integer
For i = 1 To lastrow
If (Cells(i, 4) = "") Then
Cells(i, 4).FormulaR1C1 = "=ExactWordInString(RC[-3],R2C2,R2C3)"
End If
Next i

'second loop that using the second keyword at R3C2
For i = 1 To lastrow
If (Cells(i, 4) = "") Then
Cells(i, 4).FormulaR1C1 = "=ExactWordInString(RC[-3],R3C2,R3C3)"
End If
Next i

'third loop that using the third keyword
For i = 1 To lastrow
If (Cells(i, 4) = "") Then
Cells(i, 4).FormulaR1C1 = "=ExactWordInString(RC[-3],R3C2,R3C3)"
End If
Next i

'fourth loop....
'......

End Sub

[Bob Phillips]

Can you explain a bit more what the lookup logic is, it doesn't jump out at me.

[Paul_Hossler]

I'd just do a simple user defined function



Function ExactWordInString(Text As String, WordsAndWorktype As Range) As String
Dim i As Long, n As Long

ExactWordInString = Empty

With WordsAndWorktype
For i = 2 To .Rows.Count
n = 0
On Error Resume Next
n = InStr(1, Text, .Cells(i, 1).Value, vbTextCompare)
On Error GoTo 0

If n > 0 Then
ExactWordInString = .Cells(i, 2).Value
Exit Function
End If
Next i
End With
End Function


This one also only finds the first keyword match, but you don't need the looping sub FindKeywords () at all

Paul

[mdmackillop]

Have a look here (http://www.vbaexpress.com/forum/showpost.php?p=255895&postcount=17)