Need Marco to review row for an array of codes and update cell with yes or no

Hello,

I have been trying to write some code for days with little luck. I finally thought I had it but the results turned out to be all or nothing versus each individual row. Now I am turning to you kind people for some help.

What I have is a spreadsheet containing 25350 rows (and growing) with 33 columns of data. Column A = Client ID, Column B = Benefit Code, Column C = Benefit description and columns D - AG = billing codes.

Each row may have as little as 1 billing code (so only column D would be populated) or could be maxed out at 30. Also, the billing codes are not listed in any consistant order. What I need to do is cycle through each cell columns D thru AG (row by row) and if any one of these, HP, RW, RO, RU, RI, QS or PI are found I need AH of that row updated with "Yes" Where not found AH can be left blank or populated with "No" it does not matter.

Below are 2 distictly different peices of VBA that I have tried. The last 2, I am not bothering with the first 4 or 5. Code 1 is just as likely to stop responding as it is to finish. The results of both were the same, each and every row was determined to be positive. That leaves me to think that it is checking the entire spreadsheet and if any of the billing codes are found anywhere then the VBA determines it is a success for all rows and that is not what I need.

Any help at all would be greatly appreciated.

Thanks

Rob

Code 1
Sub Med_PPO()
Dim rng As Range
Dim row As Range
Dim cel As Range
Dim mr As Long

Dim mp As Variant, strBelong As String
mp = Array("HP", "RW", "RO", "RI", "RU", "QS", "PI", "IP", "SQ")
mr = 2
Set rng = Range("D:D")

For Each row In rng.Rows
For Each cel In row.Cells
On Error Resume Next
If WorksheetFunction.Match(cel, mp, 0) <> 0 Then
Range("AH" & row) = "Yes"
End If
Next cel
Next row
End Sub

code 2:
Sub Medical_PPO()
Dim DataRange As Variant
Dim Irow As Long
Dim MaxRows As Long
Dim Icol As Long
Dim MaxCols As Long
Dim MyVar As Double
DataRange = Range("d2").CurrentRegion.Value ' Not using set
Dim mp As Variant, strBelong As String
mp = Array("HP", "RW", "RO", "RI", "RU", "QS", "PI", "IP", "SQ")


MaxRows = Range("d2").CurrentRegion.Rows.Count
MaxCols = Range("d2").CurrentRegion.Columns.Count
For Irow = 2 To MaxRows
For Icol = 4 To MaxCols
strBelong = ActiveCell.Value
On Error Resume Next
If WorksheetFunction.Match(strBelong, mp, 0) <> 0 Then
Range("AH" & Irow) = "Yes"

End If

Next Icol

Next Irow
End Sub

Try this. Should be fairly efficient.

Sub PickMe()
Dim LR As Long, LC As Long, icell As Long
Dim myArray As Variant, x As Variant
Dim iFind As Range

Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
myArray = Array("HP", "RW", "RO", "RI", "RU", "QS", "PI", "IP", "SQ")

For icell = 1 To LR
    LC = Cells(Range("D" & icell).Row, Columns.Count).End(xlToLeft).Column
        For x = LBound(myArray) To UBound(myArray)
            Set iFind = Cells(Range("D" & icell).Row, LC).Find(What:=myArray(x), LookIn:=xlValues, LookAt:=xlWhole)
            If Not iFind Is Nothing Then
                Range("AH" & icell).Value = "Yes"
                Exit For
            End If
        Next x
Next icell
Application.ScreenUpdating = True

End Sub

Thanks stnknts. This code is amazingly fast, at least compared to the code I was using. However, this code has one small flaw. It only populates AH with Yes if an array value is found in the last used column for the given row. I have been trying to work through the code but my skill set is not strong enough to figure why it only recognizes the last used column, can you give me some ideas on what needs to be modified?

Thanks

Rob

Sorry about that. Try this modification:

Sub PickMe()
Dim LR As Long, LC As Long, icell As Long
Dim myArray As Variant, x As Variant
Dim iFind As Range

Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
myArray = Array("HP", "RW", "RO", "RI", "RU", "QS", "PI", "IP", "SQ")

For icell = 1 To LR
    LC = Cells(Range("D" & icell).Row, Columns.Count).End(xlToLeft).Column
        For x = LBound(myArray) To UBound(myArray)
            Set iFind = Range(("D" & icell), Cells(icell, LC)).Find(What:=myArray(x), LookIn:=xlValues, LookAt:=xlWhole)
            If Not iFind Is Nothing Then
                Range("AH" & icell).Value = "Yes"
                Exit For
            End If
        Next x
Next icell
Application.ScreenUpdating = True

End Sub

Perfect! and fast!

Thanks for the help, it is much appreciated.