Search and highlight only containing text

This is the amended code for your SEARCH button:

Private Sub Search_Click()
Dim LR As Long, Val As String, cell As Range, Rng As Range
Dim dSh As Worksheet, v

'Setup
    Application.ScreenUpdating = False
    Val = Range("E2").Value
    Set dSh = Sheets("DATABASE")
    Range("A9:F200").ClearContents

'Transfer matching data
    LR = dSh.Range("A" & Rows.Count).End(xlUp).Row
    dSh.Range("A2").AutoFilter
    dSh.Range("A2").AutoFilter Field:=1, Criteria1:="=*" & Val & "*"
    dSh.Range("B2:F" & LR).SpecialCells(xlCellTypeVisible).Copy Range("B9")
    dSh.Range("A2").AutoFilter

'Color matching strings
    LR = Range("B" & Rows.Count).End(xlUp).Row
    Set Rng = Range("B10:F" & LR)

    For Each cell In Rng
        v = InStr(cell.Text, Val)
        If v > 0 Then
            cell.Characters(Start:=v, Length:=Len(Val)).Font.ColorIndex = 3
            v = 0
        End If
    Next cell

Application.ScreenUpdating = True
End Sub