Makro Kullanarak Koşullu Biçimlendirme

Private Sub Worksheet_Change(ByVal Target As range)
    If Intersect(Target, [e1]) Is Nothing Then Exit Sub

    Dim Bul As range, _
        Adr As String, _
        Sat As Long, _
        sv  As Worksheet
    Set sv = Sheets("PERSONEL")

    Application.ScreenUpdating = False
    Sat = Cells(Rows.Count, "a").End(3).Row
    If Sat < 7 Then Sat = 7
    'range("A5:E" & Sat).ClearContents
    range("A7:G" & Rows.Count).Clear
    Sat = 6

    With sv.range("E:E")
        Set Bul = .Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not Bul Is Nothing Then
            Adr = Bul.Address
            Do
                If sv.Cells(Bul.Row, "AF") = Cells(1, 6) Then
                Sat = Sat + 1
                Cells(Sat, "A") = sv.Cells(Bul.Row, "S")
                Cells(Sat, "C") = sv.Cells(Bul.Row, "A")
                Cells(Sat, "D") = sv.Cells(Bul.Row, "I")
                Cells(Sat, "E") = sv.Cells(Bul.Row, "B")
                Cells(Sat, "F") = sv.Cells(Bul.Row, "R")
                Cells(Sat, "G") = sv.Cells(Bul.Row, "L")
                Columns("F:F").NumberFormat = "[<=9999999]###-####;(###) ###-####"
                Columns("B:C").HorizontalAlignment = xlCenter
                Columns("F:F").HorizontalAlignment = xlCenter
               End If

                Set Bul = .FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adr
        End If
    End With
            range("A7:F" & Cells(Rows.Count, 1).End(3).Row).Borders.LineStyle = 1
      For sira = 1 To WorksheetFunction.CountA(range("C1:C65536")) - 1
range("B" & sira + 6) = sira
Next

    Application.ScreenUpdating = True
'    If Sat - 4 = 0 Then
'        MsgBox "AKTARILACAK BİLGİ BULUNMAMIŞTIR", vbCritical + vbInformation
'    Else
'        MsgBox Sat - 6 & " ADET KAYIT AKTARILMIŞTIR", vbInformation
'        End If
End Sub