Deneyiniz kod ile yaptım.

Private Sub btnAktar_Click()

    Dim i As Byte, k As Byte, topla As Integer

    Const baslangic As Byte = 3

    Const bitis As Byte = 66

    Const bitisYarisi As Byte = 33

    Const A As String = "A"

    Const B As String = "B"

    Const D As String = "D"

    Const E As String = "E"

    

    Range("I3:J33").ClearContents

'Haftasonu bulmak icin

    For i = baslangic To bitis

        For k = baslangic To bitis

            If k > bitisYarisi Then GoTo var

            If Cells(i, B).Value <> "" And Cells(i, B).Value = Cells(k, B).Value Then

                If Weekday(Cells(k, A), 2) >= 6 Then topla = topla + 1

            End If

var:

            If Cells(i, E).Value <> "" And Cells(i, E).Value = Cells(k, E).Value Then

                If Weekday(Cells(k, D), 2) >= 6 Then topla = topla + 1

            End If



        Next

        Cells(i, "j").Value = IIf(topla = 0, "", topla)

        topla = Empty

    Next

    

    topla = Empty

'Haftaici bulmak icin

    For i = baslangic To bitis

        For k = baslangic To bitis

            If k > bitisYarisi Then GoTo var2

            If Cells(i, B).Value <> "" And Cells(i, B).Value = Cells(k, B).Value Then

                If Weekday(Cells(k, A), 2) < 6 Then topla = topla + 1

            End If

var2:

            If Cells(i, E).Value <> "" And Cells(i, E).Value = Cells(k, E).Value Then

                If Weekday(Cells(k, D), 2) < 6 Then topla = topla + 1

            End If



        Next

        Cells(i, "i").Value = IIf(topla = 0, "", topla)

        topla = Empty

    Next



End Sub