Sub FindAndHighlight(SearchData As Variant, SearchRange As Range, HighlightColor As Long)
Dim FirstAddress As String
Dim SearchCell As Range
Dim SrcWks As Worksheet
Set SrcWks = Worksheets(SearchRange.Parent.Name)
Set SearchCell = SearchRange.Find(What:=SearchData, After:=SearchRange.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
If Not SearchCell Is Nothing Then
FirstAddress = SearchCell.Address
Do
SearchCell.Cells.Interior.ColorIndex = HighlightColor
Set SearchCell = SearchRange.FindNext(SearchCell)
Loop While Not SearchCell Is Nothing And SearchCell.Address <> FirstAddress
End If
End Sub
Sub HighlightRisk()
Dim LastRow As Long
Dim RiskCol As Variant
Dim RiskRange As Range
Dim StartRow As Long
RiskCol = "A"
StartRow = 1
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, RiskCol).End(xlUp).Row
LastRow = IIf(LastRow < StartRow, StartRow, LastRow)
Set RiskRange = .Range(.Cells(StartRow, RiskCol), .Cells(LastRow, RiskCol))
End With
FindAndHighlight "BT", RiskRange, 3 'Red
FindAndHighlight "BTG", RiskRange, 5 'Blue
FindAndHighlight "BTI", RiskRange, 4 'Green
FindAndHighlight "BTP", RiskRange, 1
FindAndHighlight "NT", RiskRange, 16
FindAndHighlight "NTG", RiskRange, 2
FindAndHighlight "NTI", RiskRange, 8
FindAndHighlight "NTP", RiskRange, 9
FindAndHighlight "PT", RiskRange, 10
FindAndHighlight "RT", RiskRange, 11
FindAndHighlight "SQE", RiskRange, 12
FindAndHighlight "TR", RiskRange, 13
FindAndHighlight "TRSYN", RiskRange, 14
FindAndHighlight "TT", RiskRange, 15
End Sub
Bookmarks