Solved: conditional formatting

[vdeen]

hi,

I have written a code to find text from a range( "C") and then bring the search results in a new page.

help me with a code, so I could diffrentiate the search results, on which column it was drawn from.

thanks

[stanleydgrom]

vdeen,

Please post your code using code tags.


Have a great day,
Stan

[vdeen]

hi,

here is my code.

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")

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("A12").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

[vdeen]

[VBA]
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")

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("A12").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



[/VBA]

vdeen,

Please post your code using code tags.


Have a great day,
Stan

[stanleydgrom]

vdeen,

Can you attach your workbook?

Does this line of code save the found cell address in the array?
FindCell(Counter) = Cell.Address(False, False)

You could probably put into column C the "Cell.Address" from above:
[vba]
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)

'????
Range("C" & Counter + 2).Value = FindCell(Counter)


Next Counter
[/vba]


Have a great day,
Stan

[vdeen]

hi,

my attachement as requested.

[stanleydgrom]

vdeen,

Not attached.


Have a great day,
Stan

[vdeen]

hi,

thanks for my previous code, however, I would prefer the column heading displayed, rather than cell addresss. I have uploaded my file now.

thanks

[stanleydgrom]

vdeen,

Got it. Let me check.

Right now your code is not working.

Are you searching just in column C, or C and D?


Have a great day,
Stan

[vdeen]

Stan,

I am searching range C & D.

thanks

[stanleydgrom]

vdeen,

On the attached workbook, see the sheet "Filter Criteria", and the comments in cells I3 and I8.

Have a great day,
Stan

[Carl A]

...