Accesden excele süzme - Baskı Önizleme

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