Solved: conditional formatting

[vdeen]

hi,

I have the following code. I would like to color cells in different colours, to differentiate if result was from column C or column D, as they are my find range.

thanks

Public Sub DoFindAll()
FindAll "", "True"
End Sub

Public Sub FindAll(Search As String, Reset As Boolean)

Dim WB As Workbook
Dim WS As Worksheet
Dim Cell As Range
Dim Prompt As String
Dim Title As String
Dim FindCell() As String
Dim FindSheet() As String
Dim FindWorkBook() As String
Dim FindPath() As String
Dim FindText() As String
Dim Counter As Long
Dim FirstAddress As String
Dim Path As String

If Search = "" Then
Prompt = "What do you want to search for?" & _
vbNewLine & vbNewLine & Path
Title = "Search Criteria Input"
Search = InputBox(Prompt, Title, "Enter search term")
If Search = "" Then
GoTo Cancelled
End If
End If


On Error GoTo Cancelled

Set WB = ActiveWorkbook
For Each WS In WB.Worksheets
If WS.Name <> "SEARCH RESULTS" Then

'Alternative to search single column
With WB.Sheets(WS.Name).Range("C:D")

Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchOrder:=xlByColumns)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Counter = Counter + 1
ReDim Preserve FindCell(1 To Counter)
ReDim Preserve FindSheet(1 To Counter)
ReDim Preserve FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.Text
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
End If
End With
End If
Next

'If no result found, reset properties and exit sub
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
'Clear old results if required
'Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
'**********************************
GoTo Cancelled
End If

'Add SearchWord sheet if not present
On Error Resume Next
Sheets("SEARCH RESULTS").Select
If Err <> 0 Then
Debug.Print Err
'error occured so clear it
Err.Clear
Sheets.Add.Name = "SEARCH RESULTS"
Sheets("SEARCH RESULTS").Move After:=Sheets(Sheets.Count)
'Run macro to add code to ThisWorkbook

End If

'Clear old data and then format results page as required
Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
Range("A1:B1").Interior.ColorIndex = 37
Range("A1").Value = "Search of:"
If Reset = True Then Range("B1").Value = Search
Range("A1:D2").Font.Bold = True
Range("A2").Value = "Link"
Range("B2").Value = "Cell Text"
Range("A1:B1").HorizontalAlignment = xlLeft
Range("A2:B2").HorizontalAlignment = xlCenter
With Columns("A:A")
.ColumnWidth = 25
.VerticalAlignment = xlTop
End With
With Columns("B:B")
.ColumnWidth = 50
.VerticalAlignment = xlCenter
.WrapText = True
End With

'Add hyperlinks and results to spreadsheet
For Counter = 1 To UBound(FindCell)
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
Address:="", SubAddress:="'" & FindSheet(Counter) & "'" & "!" & FindCell(Counter), _
TextToDisplay:="CLICK HERE FOR ANZSIC"
Range("B" & Counter + 2).Value = FindText(Counter)


Next Counter

'Find search term on results page and colour text
ColourText

Cancelled:

Set WB = Nothing
Set WS = Nothing
Set Cell = Nothing


End Sub

Sub ColourText()
Dim Strt As Long, x As Long, i As Long
Columns("B:B").Characters.Font.ColorIndex = xlAutomatic
For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
x = 1
Do
Strt = InStr(x, Range("B" & i), [B1], 1)
If Strt = 0 Then Exit Do
Range("B" & i).Characters(Start:=Strt, _
Length:=Len([B1])).Font.ColorIndex = 7
x = Strt + 1
Loop
Next
End Sub

~Code Tags Added By Oorang