Kod:
Option Explicit
Sub Sil()
Range("B9:I3000").ClearContents
End Sub
Private Sub TextBox1_Change()
Dim sonsat As Long, Deg As String, hcr As Range, Aln As Range, Code As Boolean
Dim vsyf As Worksheet, renk
Sheets("ARAMA").Activate
If Range("E3") <> "" Then
Deg = Range("E3").Value
Else
MsgBox "BİR ARAMA KRİTERİ GİRİN..."
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Set vsyf = Sheets("VERİ")
Range("A9:I3000").ClearContents
sonsat = vsyf.Range("A" & Rows.Count).End(xlUp).Row
vsyf.Range("B2").AutoFilter
vsyf.Range("B2").AutoFilter Field:=3, Criteria1:="=*" & Deg & "*"
vsyf.Range("B2:I" & sonsat).SpecialCells(xlCellTypeVisible).Copy Range("B9")
vsyf.Range("B2").AutoFilter
sonsat = Range("B" & Rows.Count).End(xlUp).Row
Set Aln = Range("C9:C" & sonsat)
For Each hcr In Aln
renk = InStr(renk + 1, hcr.Text, Deg)
Do
If renk > 0 Then
hcr.Characters(Start:=renk, Length:=Len(Deg)).Font.ColorIndex = 7
End If
renk = InStr(renk + 1, hcr.Text, Deg)
Loop While renk > 0
Next hcr
Application.ScreenUpdating = True
Application.EnableEvents = True
End SubÖrnek dosya ekte. Yardımlarınızı bekliyorum
