Excel Search - want to make the search word Bold 4

[JustineB]

Hi all

I have a spreadsheet with a 'Search' area. The User enters a search phrase or word and the code loops through the spreadsheet and returns any rows that contain the expression or word into a new sheet.

This all works fine. I have now been asked if the search phrase or word can be highlighted (bold) in the new spreadsheet. I have tried to do this, but end up with the row as bold rather then the word.

Can anyone help?

Here is my code:

'Private Sub CommandButton1_Click()
Option Compare Text

Sub Button5_Click()

Application.ScreenUpdating = False

    Dim SearchRow As Integer
    Dim CopyRow As Integer
    Dim CopySheet As String
    Dim SearchText As String
    Dim SearchText2 As String
    Dim Col As String
    Dim Col2 As String
    Dim Row As Integer
    Dim SearchPage As String
    
    

    On Error GoTo Err_Execute

    'Set Search Page to copy from
    SearchPage = "Summary"
    
    'copy data to row 4 in Sheet2
    CopyRow = 4
    
    'Set start Row for Search Boxes (on search page)
    Row = 3
        
    'Set Column Number to search in
    'jub removed oct06 - Col = Range("H" & CStr(Row)).Value
    Col = "A"
        
    'Set Column Number 2 to search in
    'jub removed oct06 - Col2 = Range("H" & CStr(Row + 1)).Value
    Col2 = "C"
        
    'Set SearchText for Col
    'jub changed here
    SearchText = Range("D" & CStr(Row)).Value
    
    'Set SearchText for Col2
    SearchText = Range("D" & CStr(Row)).Value
    
    'Start search in row of the sheet to copy from
    SearchRow = 2
    

    
    'Copy data to Sheet Number
    CopySheet = "Navigator"
  
     
    
    
'MsgBox "All data on " & CopySheet & " will be deleted first" (MDI Commented)

    
Sheets(CopySheet).Rows.Delete

Sheets(SearchPage).Select
Rows(CStr(1) & ":" & CStr(1)).Select
Selection.Copy
Sheets(CopySheet).Select
Sheets(CopySheet).Rows(CStr(1) & ":" & CStr(1)).Select
ActiveSheet.Paste
Sheets(SearchPage).Select

    While Len(Range(Col & CStr(SearchRow)).Value) > 0
    
            
                If InStr((Range(Col & CStr(SearchRow)).Value), SearchText) > 0 Or _
                InStr((Range(Col2 & CStr(SearchRow)).Value), SearchText) > 0 Then
                
                'If ((Range(Col & CStr(SearchRow)).Value Like (SearchText) Or _
                'Range(Col & CStr(SearchRow)).Value = (SearchText))) Or _
                '((Range(Col2 & CStr(SearchRow)).Value Like (SearchText) Or _
                'Range(Col2 & CStr(SearchRow)).Value = (SearchText))) Then
                
                                           
                             
                'Select row to copy (from Sheet1)
                Rows(CStr(SearchRow) & ":" & CStr(SearchRow)).Select
                Selection.Copy
                   
                'Paste row into Sheet2
                Sheets(CopySheet).Select
                Sheets(CopySheet).Rows(CStr(CopyRow) & ":" & CStr(CopyRow)).Select
                ActiveSheet.Paste
            
                'Move to next row
                CopyRow = CopyRow + 1

                'Go back to Sheet1 to continue searching
                Sheets(SearchPage).Select
                
                'End If
            
                
                Else
                
                If Not IsNull(Col2) Then
                
                 If InStr((Range(Col & CStr(SearchRow)).Value), SearchText) > 0 Or _
                 InStr((Range(Col2 & CStr(SearchRow)).Value), SearchText) > 0 Then
               
                
                    'If ((Range(Col & CStr(SearchRow)).Value Like (SearchText) Or _
                      '  Range(Col & CStr(SearchRow)).Value = (SearchText)) And _
                     '   (Range(Col2 & CStr(SearchRow)).Value Like (SearchText2) Or _
                     '   Range(Col2 & CStr(SearchRow)).Value = (SearchText2))) Then
                    
                
                        'Select row to copy (from Sheet1)
                        Rows(CStr(SearchRow) & ":" & CStr(SearchRow)).Select
                        Selection.Copy

                        'Paste row into Sheet2
                        Sheets(CopySheet).Select
                        Sheets(CopySheet).Rows(CStr(CopyRow) & ":" & CStr(CopyRow)).Select
                        ActiveSheet.Paste
                                    
            
                        'Move to next row
                        CopyRow = CopyRow + 1

                        'Go back to Sheet1 to continue searching
                        Sheets(SearchPage).Select
                    End If
                
                End If
                                

            End If

        SearchRow = SearchRow + 1

    Wend

    'Position on cell A3
    Application.CutCopyMode = False
    'Range("A3").Select

    'MsgBox "All matching data has been copied to & (CopySheet)" (MDI Commented)
    
    Sheets(CopySheet).Select
    ActiveSheet.UsedRange.Columns.AutoFit
    
    Columns("A:A").ColumnWidth = 25
    Columns("B:B").ColumnWidth = 12
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").ColumnWidth = 22
    Columns("E:E").ColumnWidth = 12
    Columns("F:F").ColumnWidth = 9
    Columns("G:G").ColumnWidth = 12
    Columns("H:H").ColumnWidth = 18

    Cells.Select
    Cells.EntireRow.AutoFit

    Rows("2:3").Select
    Selection.Delete Shift:=xlUp

        Range("C3").Select
    Range("A1:H1000").Sort Key1:=Range("C3"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A3").Select
    Range("A1:H1000").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

    Range("A1").Select

    Exit Sub

Err_Execute:
    MsgBox "An error occurred..."

End Sub

Sub NewSearch()

    Sheets("Search").Select

End Sub

 

[xlbo]

Maybe I'm missing something here but there is no BOLD statement anywhere in your code.....

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[JustineB]

Sorry - I removed it and left the code as it was before I started playing with it.

I can re-post with the code that made the whole row bold if you like, I removed it as it wasn't doing what I needed it to.

Many thanks,
Justine

 

[xlbo]

yes - please post the code - but just the relevant bit with a few lines before and a few lines after

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[vladk]

May be this thread707-1248145 will help. I believe, it shows how to highlight some characters in a cell.

 

[JustineB]

Hi Geoff

Here is the code that loops through and checks to see if the word that I am searching for exists in the coloumn and row that I am searching in. This code makes the whole line of text in the column bold, rather than just the word that I am searching for.

EG: If I am searching for the word 'Cat' and the range A:7 contains 'The Cat sat on the mat' the whole Expression: The Cat Sat on the Mat is in bold rather than: The Cat sat on the Mat.

Any help will be gratefully received.

Dim FindTextinRow As String
Dim FindTextInColumn As String
Dim FindTextInColumn2 As String
Dim Searchfortext As Range

    FindTextInColumn = "A"
    FindTextInColumn2 = "C"
    FindTextinRow = "1"
    'Set Searchfortext = Range(CStr(FindTextInColumn) & CStr(FindTextinRow))
     Application.ScreenUpdating = False
     
     While Len(Range(FindTextInColumn & CStr(FindTextinRow)).Value) > 0
     
     
     
     Range(CStr(FindTextInColumn) & CStr(FindTextinRow)).Select
        If InStr(Selection, SearchText) Then
        Selection.Font.Bold = True
  
        End If

    FindTextinRow = FindTextinRow + 1

Wend

Many thanks in advance

Justine

 

[ck1999]

It would be more time consuming by you may have to do a comparison using a loop through the cell to see where your search word is. This code below works just replace to make c=search field.

you might need to modify slightly worked for me when e8 = "the cat in the hat and a black cat"


Sub hh()
searchtext = "cat"
c = Range("e8").Text
searchboolean = False
For counter1 = 1 To Len(c)
searchboolean = False
b = Mid(c, counter1, 1)
If b = Left(searchtext, 1) Then
For counter2 = 1 To Len(searchtext)
bb = Mid(c, counter1, counter2)
If bb = Left(searchtext, counter2) Then
searchboolean = True
Else
searchboolean = False
End If
Next counter2
If searchboolean = True Then
ActiveCell.Characters(Start:=counter1, Length:=counter2).Font.FontStyle = "Bold"
End If
End If


Next counter1


End Sub

ck1999

 

[xlbo]

ok - should be an easier way than that:

You can use the FIND method to get the cell where the text is

dim strText as string, lenText as integer, stPos as integer

strText = "Cat"
lenText = len(strText)

[COLOR=green]'Use this to find the cell which contains the text - column A only for this example[/color]
set fCell = Sheets("SheetName").Columns("A").find(strText, lookin:=xlvalues, lookat:=xlpart)

if not fCell is nothing then
 [COLOR=green]'text has been found[/color]
 [COLOR=green]'Find where in cell text starts[/color]
 stPos = instr(fCell.text, strText)
 [COLOR=green]'Use the start position and the length of the word to bold the appropriate characters[/color]
 fCell.characters(stPos, lenText).Font.Bold = true
else
 [COLOR=green]'text not found in column[/color]
end if

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[ck1999]

xlbo,

I tried your code and it only would change the 1st the characters in the cell to bold. I was having the stpos returned as 0.

ck1999

 

[ck1999]

I changed your code to this

stPos = InStr(1, fcell.Text, strText, 1)

and it did work however, If there were two of the same words in the same cell it would only bold the 1st word.


Ck1999

 

[PHV]

If there were two of the same words in the same cell it would only bold the 1st word
Typed, untested:
stPos = 1
Do
stPos = InStr(stPos, fCell.Text, strText, vbTextCompare)
If stPos = 0 Then Exit Do
fCell.Characters(stPos, lenText).Font.Bold = True
stPos = stPos + lenText
Loop

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[SkipVought]

How about this. This is what I have in mu ActiveCell
[tt]
the cat in the hat was a cat for a catastrophy and catoclysmic catenary
[/tt]

Sub test()
    Dim a, i, l, s
    With ActiveCell
        s = "cat"
        a = Split(.Value, s)
        
        For i = 0 To UBound(a) - 1
            l = l + Len(a(i))
            .Characters(l + 1, Len(s)).Font.Bold = True
            l = l + Len(s)
        Next
    End With
End Sub

it gets them all

Skip,
[sub]
[red][/red]
[/sub]

 

[JustineB]

You are all brilliant!!!
Thank you so much! This has been driving me insane.

Here is what I ended up with:

Dim strText As String, lenText As Integer, stPos As Integer, Srow As Integer

strText = SearchText
lenText = Len(strText)
Srow = 2

While Len(Range("C" & CStr(Srow)).Value) > 0

      Set fCell = Sheets("Navigator").Columns("C").Rows(Srow).Find(strText, LookIn:=xlValues, lookat:=xlPart)

        If Not fCell Is Nothing Then
    
        stPos = InStr(fCell.Text, strText)
    
    
        fCell.Characters(stPos, lenText).Font.Bold = True
          
        Else
        
        End If
    Srow = Srow + 1
Wend

I have given each of you a star as I took some of each answer to get it working.

Many, many thanks again!
and Merry Christmas too.

Justine

 

[xlbo]

Would've thought you could do the loop within the find - should be faster:

Dim strText As String, lenText As Integer, stPos As Integer, [b]firstAddress as string[/b]

strText = SearchText
lenText = Len(strText)

[b]with Sheets("Navigator").Columns("C")[/b]

      Set fCell = .Find(strText, LookIn:=xlValues, lookat:=xlPart)

        If Not fCell Is Nothing Then
          
           [b]firstAddress = fCell.Address
         Do[/b]
           stPos = InStr(fCell.Text, strText)
        
           fCell.Characters(stPos, lenText).Font.Bold = True
            
           [b]Set fCell = .FindNext(fCell)

         Loop While Not fCell Is Nothing And fCell.Address <> firstAddress[/b]
    
        Else
        
        End If
[b]end with[/b]

If your code works then by all means keep using it but as an extra bit of advice, the FIND method will only loop through the cells where the text is and should therefore be faster than looping and checking each row. If you only have a few hundred rows of data, the difference should be negligible but if you have a few thousand, you should see quite a difference in performance

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question