Berduş hocamızın 2.soru için çözümünü uygulayıp Dictionary ile yaptırdım.Extra sayfaya gerek kalmadı.Önceki sayfa eklenmesi sebebi sıralatmak içindi eğer ANA LİSTE sayfası sıralı gidiyorsa alttaki dosyada denenebilir.
Yukardaki kod yazdırma alanı için.Gerçi .Address olan satır olmasada çalışıyor.

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

@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?

(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?

Dizi ilede yapıldı abey.Dictionary deki amaç mesela 2011 den sonra 2012 geliyor ve böyle gidiyor.Ordaki veriyi aldırmak içindi.Sizinki yanılmıyorsam dediğim olayı birleştirme gibi yapmıştınız virgülle.

Günaydın.
herşey güzel olmuş, ancak son satıra ekleme yaptığımda sıralamayı doğru yapıyor ancak yeni bir yıl başlangıcı imiş gibi yazı tipini renklendiriyor.

şimdi denedim 8-9 satır ekledim sonuncu 2020 diğerleri 2019du sorunsuz çalıştı sadece 2020li olanın rengi değişti

hatta şimdi 30-40 kayıt ekleyerek yeniden denedim 20-30 tanesi 2020 diğerler 2019 yine sorunsuz çalıştı