Sub ListeAktarDz()
    Dim SonStr As Long, strx As Long, x, bul As Range
    Dim Sht As Worksheet, i As Long, DzStr As Long, DzStn As Long
    Dim ShtHdf As Worksheet
    Dim Dizi() As Variant
    Dim DiziKynk() As Variant
    Const sutun As Byte = 12
    Dim dic As Object
    
    Set Sht = ThisWorkbook.Worksheets("ANA LİSTE")
    Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA")
    
    ShtHdf.Range("A2", ShtHdf.Cells(Rows.Count, "XFD")).Clear
    SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row
    
    If SonStr < 2 Then GoTo son
    If SonStr = 2 Then
        ShtHdf.Range("A2").Value = Sht.Range("A2").Value
        GoTo son
    End If
    
    StrSay = (SonStr - 1) \ sutun + 1
    ReDim Dizi(StrSay, sutun)
    DiziKynk = Sht.Range("A2:A" & SonStr)
    
    TmpYnYil = Left(Sht.Range("A2"), 4)
    DzStr = 0
    DzStn = 0
    StrSay = ((SonStr - 1) \ sutun) + 1 + Left(Sht.Range("A" & SonStr), 4) - Left(Sht.Range("A2"), 4) + 1
    ReDim Dizi(StrSay, sutun)
    DiziKynk = Sht.Range("A2:A" & SonStr)
    
    i = 0
    For strx = LBound(DiziKynk) To UBound(DiziKynk)
    
    If TmpYnYil <> Left(DiziKynk(strx, 1), 4) Then
        DzStr = IIf(DzStn > 0, DzStr + 1, DzStr)
        DzStn = 0
        TmpYnYil = Left(DiziKynk(strx, 1), 4)
    End If
    Dizi(DzStr, DzStn) = DiziKynk(strx, 1)
    DzStn = DzStn + 1
    
    If DzStn = sutun Then
        DzStn = 0
        DzStr = DzStr + 1
    End If
    Next strx
    
    ShtHdf.Range("A2").Resize(UBound(Dizi, 1) - 1, sutun).Value = Dizi
    Set dic = CreateObject("Scripting.Dictionary")
    
    For strx = LBound(DiziKynk) To UBound(DiziKynk)
        If Not dic.exists(Left(DiziKynk(strx, 1), 4)) Then dic.Add Left(DiziKynk(strx, 1), 4), DiziKynk(strx, 1)
            
    Next
    
    For Each x In dic.items
        Set bul = ShtHdf.Cells.Find(x, , , 1)
        If Not bul Is Nothing Then
            bul.Font.Bold = True: bul.Font.Color = vbRed
        End If
    Next
    SonStr = ShtHdf.Cells(Sht.Rows.Count, "A").End(xlUp).Row
    If SonStr < 2 Then GoTo son
    ShtHdf.Range("A2").Resize(SonStr - 1, sutun).Borders.LineStyle = 1
    ShtHdf.PageSetup.PrintArea = ""
    ShtHdf.PageSetup.PrintArea = ShtHdf.Range("A1").Resize(SonStr, sutun).Address
    
son:
    On Error Resume Next
    Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing: Set dic = Nothing: Set bul = Nothing
    MsgBox "bitti"
End Sub