Bende bitmiş halini ekleyeyim.Arama için alanları karıştırmışım.Renk için olayına girmedim.

Private Sub SayfayýHazýrla_Click()



Dim bul As Range, s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, arr2()

Dim arr(), i As Long, son As Long, dogru As Boolean, say As Long, soncomboSayfa As Long

Application.ScreenUpdating = False

If Len(Trim(Me.ComboBox1.Value)) = 0 Then

    MsgBox "Sayfa seciniz...", vbCritical, "Safa sec"

    Exit Sub

End If



Set s1 = ThisWorkbook.Sheets("VERÝ") 'Veri

Set s2 = ThisWorkbook.Sheets("KONTROL") 'Kontrol

Set s3 = ThisWorkbook.Sheets(Me.ComboBox1.Value)

son = s1.Cells(Rows.Count, 1).End(3).Row

soncomboSayfa = s3.Cells(Rows.Count, "Aj").End(3).Row

If soncomboSayfa < 7 Then soncomboSayfa = 7



If son < 2 Then GoTo son

ReDim arr(1 To son, 1 To 5)

say = 1

On Error Resume Next

s3.Range("A7:AJ" & Rows.Count).UnMerge

s3.Range("A7:AJ" & Rows.Count).ClearContents

s3.Range("A7:AJ" & Rows.Count).Borders.LineStyle = xlNone

On Error GoTo 0

For i = 2 To son

    dogru = False

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 2).Value, , , 1) 'Sicil

    If Not bul Is Nothing Then dogru = True

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 5).Value, , , 1) 'ad

    If Not bul Is Nothing Then dogru = True

    Set bul = s2.Range("D:F").Find(s1.Cells(i, 6).Value, , , 1) 'soyad

    If Not bul Is Nothing Then dogru = True

    If dogru = False Then

        arr(say, 1) = say

        arr(say, 2) = s1.Cells(i, 2).Value + 0

        arr(say, 3) = s1.Cells(i, 5).Value

        arr(say, 4) = s1.Cells(i, 3).Value

        arr(say, 5) = s1.Cells(i, 4).Value

        say = say + 1

    End If

Next

If say > 1 Then

    s3.Range("A7").Resize(say, UBound(arr, 2)).Value = arr

    soncomboSayfa = s3.Cells(Rows.Count, 1).End(3).Row

    s3.Range("F7:Ai" & soncomboSayfa).Value = 1

    s3.Range("F7:AJ" & soncomboSayfa).Borders.LineStyle = 1

    ReDim arr2(1 To soncomboSayfa, 1 To 1)

    say = 0

    For i = 7 To soncomboSayfa

        say = say + 1

        arr2(say, 1) = WorksheetFunction.Sum(s3.Range(s3.Cells(i, "F"), s3.Cells(i, "Ai")))

    Next

        s3.Range("AJ7").Resize(soncomboSayfa, 1).Value = arr2

        s3.Range("B7:Aj" & soncomboSayfa).Sort s3.Range("B7"), , , , , , , xlNo

End If



son:

Application.ScreenUpdating = True

Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing: Set bul = Nothing: Erase arr: Erase arr2

MsgBox "Bitti", vbInformation, "Bitti"



End Sub

---

Tabii veri B sütununda boş karakterler olduğu için az bulmuş onada bakayım