Listeleme hk.

Private Sub CommandButton1_Click()
Dim a(), b(), dic1 As Object, dic2 As Object
Dim s1 As Worksheet, s2 As Worksheet
a = Range("D15:D" & Cells(Rows.Count, 4).End(3).Row)

Set s1 = Sheets("puantajlar")
Set s2 = Sheets("Listele")
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
a = s1.Range("B15:D" & s1.Cells(Rows.Count, 4).End(3).Row)

    ReDim b(1 To UBound(a), 1 To 2)
        For i = 1 To UBound(a)
            If a(i, 1) <> "" And a(i, 3) <> "sicil" Then
                If Not dic1.exists(a(i, 1)) Then
                    dic1(a(i, 1)) = dic1.Count + 1
                    say = dic1.Count
                    b(say, 1) = i + 12
                End If
                sat = dic1(a(i, 1))
                b(sat, 2) = i + 14
            End If
        Next i

    sicil_no = s2.[C1]
    sicil_veri = s2.[C2]
    s2.Range("F3:F" & Rows.Count).ClearContents
        For i = 1 To say
            sat_1 = Val(b(i, 1))
            sat_2 = Val(b(i, 2))
            tbl = s1.Range("D" & sat_1 & ":BV" & sat_2)
            For x = 3 To UBound(tbl)
                For j = 10 To UBound(tbl, 2)
                    If sicil_no = CStr(tbl(x, 1)) Then
                        If tbl(x, j) = sicil_veri Then
                            krt = tbl(1, j)
                            If Not dic2.exists(krt) Then
                                dic2(krt) = dic2.Count + 1
                                s = dic2.Count
                                s2.Cells(s + 2, 6) = krt
                            End If
                        End If
                    End If
                Next j
            Next x
        Next i
MsgBox "İşlem tamam.", vbInformation
End Sub

Sub deneme()
Sheets("Listele").Select
a = Range("F3:F" & Cells(Rows.Count, "F").Row).Value
hft = DatePart("w", a(1, 1))
s = 2
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            If DatePart("w", a(i, 1)) = hft Then
                s = s + 1
                Cells(s, "I") = a(i, 1)
            End If
            If Cells(s, "I") < DateAdd("d", 6, Cells(s, "I")) Then
                Cells(s, "J") = a(i, 1)
            End If
            If Cells(s, "I") = Cells(s, "J") Then
                Cells(s, "K") = 1
            Else
                Cells(s, "K") = Cells(s, "J") - Cells(s, "I")
            End If
        End If
    Next i
End Sub

Sub kod_1()
a = Range("F3:F" & Cells(Rows.Count, "F").End(3).Row).Value
On Error Resume Next

    trh_1 = a(1, 1)
    trh_2 = a(UBound(a), 1)
    son = trh_2 - trh_1
    ReDim b(1 To son + 1, 1 To 1)
        For i = 1 To son + 1
            trh_3 = DateAdd("d", i - 1, a(1, 1))
            If trh_3 Mod 7 <> 1 Then
                say = say + 1
                For j = 1 To UBound(a)
                    If trh_3 = a(j, 1) Then
                        b(say, 1) = trh_3
                    End If
                Next j
            End If
            
        Next i

    n = 1
    Set d = CreateObject("scripting.dictionary")
    ReDim c(1 To say, 1 To 2)
        For i = 1 To say
            If b(i, 1) <> "" Then
                c(i, 1) = n
            Else
                n = n + 1
            End If
            c(i, 2) = b(i, 1)
        Next i

    ReDim b(1 To UBound(c), 1 To 3)
        For i = 1 To say
            If c(i, 1) <> "" Then
                If Not d.exists(c(i, 1)) Then
                    d(c(i, 1)) = d.Count + 1
                    sat = d.Count
                    b(sat, 1) = c(i, 2)
                End If
                sat1 = d(c(i, 1))
                b(sat1, 2) = DateAdd("d", 1, c(i, 2))
                b(sat1, 3) = b(sat1, 3) + 1
            End If
        Next i

[i3].Resize(sat, 3) = b
MsgBox "işlem tamam.", vbInformation
End Sub