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

(10/02/2021, 23:32)berduş yazdı: @feraz hocam ben dizi ile yapmıştım siz dictionary ile , yanlış yorumlamadıysam tabi,
sizin deneyiminize göre  dictionary, collection, dizi  hız sıralaması nasıl?