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