I'm searching a column for matches (FindThis) and writing to cells on
the row (WriteReason) on success. The macro below works fine, but my
number of matching terms is increasing and I find myself just copying
and pasting the code over and over again. Is there a better way to
modularize this just plug in values without creating "FindThisA,
FindThisB", etc?

----

Sub Exclusions()

WriteManual = "Manual"

Const FindThisA = "MatchA"
Const WriteReasonA = "Failure Code A"
Const FindThisB = "MatchB"
Const WriteReasonB = "Failure Code B"

Dim A As Range, retA
ActiveCell.EntireColumn.Select
For Each A In Selection
retA = InStr(1, A, FindThisA, vbTextCompare)
If (Not IsNull(retA)) And (retA 0) Then
A.Offset(0, -17).Value = WriteReasonA
A.Offset(0, -20).Value = WriteManual
End If
Next A

Dim B As Range, retB
ActiveCell.EntireColumn.Select
For Each B In Selection
retB = InStr(1, B, FindThisB, vbTextCompare)
If (Not IsNull(retB)) And (retB 0) Then
B.Offset(0, -17).Value = WriteReasonB
B.Offset(0, -20).Value = WriteManual
End If
Next B

End Sub

This should help out a little:

Sub Exclusions()
Call FindExclusions("MatchA", "Failure Code A", "Manual")
Call FindExclusions("MatchB", "Failure Code B", "Manual")
End Sub

Function FindExclusions(findStr As String, writeReason As String,
writeManual As String)
Dim A As Range, retA
ActiveCell.EntireColumn.Select
For Each A In Selection
retA = InStr(1, A, findStr, vbTextCompare)
If (Not IsNull(retA)) And (retA 0) Then
A.Offset(0, -17).Value = writeReason
A.Offset(0, -20).Value = writeManual
End If
Next A
End Function

If you have a very large number of terms to search for, you could also put
all of the terms into a sheet and have the macro loop through each term.

Hope this helps!
Andy

"Blee" wrote:

I'm searching a column for matches (FindThis) and writing to cells on
the row (WriteReason) on success. The macro below works fine, but my
number of matching terms is increasing and I find myself just copying
and pasting the code over and over again. Is there a better way to
modularize this just plug in values without creating "FindThisA,
FindThisB", etc?

----

Sub Exclusions()

WriteManual = "Manual"

Const FindThisA = "MatchA"
Const WriteReasonA = "Failure Code A"
Const FindThisB = "MatchB"
Const WriteReasonB = "Failure Code B"

Dim A As Range, retA
ActiveCell.EntireColumn.Select
For Each A In Selection
retA = InStr(1, A, FindThisA, vbTextCompare)
If (Not IsNull(retA)) And (retA 0) Then
A.Offset(0, -17).Value = WriteReasonA
A.Offset(0, -20).Value = WriteManual
End If
Next A

Dim B As Range, retB
ActiveCell.EntireColumn.Select
For Each B In Selection
retB = InStr(1, B, FindThisB, vbTextCompare)
If (Not IsNull(retB)) And (retB 0) Then
B.Offset(0, -17).Value = WriteReasonB
B.Offset(0, -20).Value = WriteManual
End If
Next B

End Sub

Thanks Andy; that worked very well.

Hi Blee,
Try this instead.
As you can see there is nothing actually hard coded, its is all done
through the constants.
You can add as many failure codes as you want.
Also, this wont loop through all the cells in the colum.

Kind regards
Bernie Russell

----------------------------------------------------------------------------------
Public Sub Exclusions2()



Const ACTION As String = "Manual"
Const SEARCHPREFIX As String = "Match"
Const REASONPREFIX As String = "Failure Code "
Const OFFSETMANUAL As Integer = -17 'Or whatever offset you want.
Const OFFSETREASON As Integer = -20

Dim FailureCodes() As Variant
FailureCodes = Array("A", "B", "C", "D", "E", "F") 'Put in what ever
you want here

Dim fc As String
Dim sCVal As String

Dim i As Integer
Dim rRangeToSearch As Range
'Set rRangeToSearch = ActiveCell.EntireColumn 'Or set it like this
worksheets(1).Range("A:A")
With ActiveCell.EntireColumn
' This sets the range to be searched to the first cell in the column
to the last used cell in the column.
' So it wont have to go through 65536 cells. ie This is quicker
Set rRangeToSearch =
Range(.Cells(1), .Cells(.Cells.Count).End(xlUp))
Debug.Print rRangeToSearch.Address
End With

On Error GoTo Err_Exclusions2
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim c As Range
For Each c In rRangeToSearch.Cells
Debug.Print c.Address & " " & c.Value
With c
If Len(.Value) 0 Then
sCVal = UCase(.Value)
For i = LBound(FailureCodes) To UBound(FailureCodes)
fc = UCase(FailureCodes(i))
If InStr(1, sCVal, UCase(SEARCHPREFIX) & fc) 0 And
Len(fc) < 0 Then
.Offset(0, OFFSETREASON).Value = CStr(REASONPREFIX & fc)
.Offset(0, OFFSETMANUAL).Value = ACTION
End If
Next i
End If
End With 'c
Next c

ExitSub:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Set c = Nothing
Set rRangeToSearch = Nothing
Exit Sub

Err_Exclusions2:
MsgBox "An error occured in when running the Exclusions2 sub
procedure"
GoTo ExitSub
End Sub