iyi çalışmalar
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
Dim RngBold As String
Dim RngBoldDz() As String
Const sutun As Byte = 12
RngBold = "A2"
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
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
Erase Dizi: Set Sht = Nothing: Set ShtHdf = Nothing
MsgBox "bitti"
End Sub