fırsat bulunca diğerlerini de yapmaya çalışırım
Sub ListeAktarDz()
Dim SonStr As Long
Dim Sht As Worksheet
Dim ShtHdf As Worksheet
Dim Dizi() As Variant
Dim DiziKynk() As Variant
Dim DzStr As Long, DzStn As Byte
Const sutun As Byte = 12
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
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 = 12 Then
DzStn = 0
DzStr = DzStr + 1
End If
Next StrX
ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Value = Dizi
ShtHdf.Range("A2").Resize(UBound(Dizi, 1), sutun).Borders.LineStyle = 1
son:
' On Error Resume Next
Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing
MsgBox "bitti"
End Sub