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
Bookmarks