3. maddeden kastettiğiniz şeyi anlamadım???
diğer maddelerde de bahsettiğiniz soruna raslamadım
veri eklediğimde de sildiğimde de göstermesi gerektiği gibi gösterdi
aşağıdaki kodu dener misiniz
örnek aşağıdadır

Sub ListeAktarDz()

Dim SonStr As Long

Dim Sht As Worksheet, ShtHdf As Worksheet

Dim Dizi() As Variant, DiziKynk() As Variant

Dim DzStr As Long, DzStn As Byte

Dim RngBold As String, RngBoldDz() As String

SyfAktarSirala



Const sutun As Byte = 12

RngBold = "A2"

Set Sht = ThisWorkbook.Worksheets("TmpSrlSyf")

Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA")



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

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

    RngBold = RngBold & ", A" & DzStr + 2

    TmpYnYil = Left(DiziKynk(StrX, 1), 4)

End If

Dizi(DzStr, DzStn) = DiziKynk(StrX, 1)

DzStn = DzStn + 1



If DzStn = 12 Then

    DzStn = 0

    DzStr = DzStr + 1

End If

Next StrX

ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Value = Dizi



SonStr = ShtHdf.Cells(ShtHdf.Rows.Count, "A").End(xlUp).Row + 1

ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Borders.LineStyle = 1

ShtHdf.Range("A" & SonStr & ":L" & UBound(Dizi, 1) + 2).Clear



RngBoldDz = Split(RngBold, ",")



Dim Item As Variant

For Each Item In RngBoldDz

    ShtHdf.Range(Item).Font.Bold = True

    ShtHdf.Range(Item).Font.Color = vbRed

Next Item



son:

' On Error Resume Next

Sht.Cells.Clear

Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing



MsgBox "bitti"

End Sub

Sıralama fonksiyonu bunun için dosyanıza  TmpSrlSyf adlı sayfa eklemelisiniz

Function SyfAktarSirala()

Dim SonStr As Long

Dim Sht As Worksheet, ShtTmp As Worksheet

Set Sht = ThisWorkbook.Worksheets("ANA LİSTE")

Set ShtTmp = ThisWorkbook.Worksheets("TmpSrlSyf")



ShtTmp.Cells.Clear

SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row



Sht.Range("A:A").Copy Destination:=ShtTmp.Range("A1")

With ShtTmp

.Range("B2").Formula = "=INT(LEFT(A2,4))"

.Range("C2").Formula = "=INT(MID(A2,6,LEN(A2)))"

.Range("B2:C" & SonStr).FillDown

.Columns.Sort key1:=.Columns("B"), Order1:=xlAscending, Key2:=.Columns("C"), Order2:=xlAscending, Header:=xlYes

End With

End Function