Sınav Değerlendirme

Yok onun farkındayım ama sonradan hep bir şey çıkıyor eklemeyi unutuyorum) )

Buda benden olsun.

Sub AKTAR()

    Dim Sht As Worksheet, ShtHdf As Worksheet

    Dim i As Long, SonStr As Long, say As Long

    

    Application.ScreenUpdating = False

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

    Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA")

    

    ShtHdf.Range("A2:L" & Rows.Count).Clear

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

    say = 2

    If WorksheetFunction.CountA(Sht.Range("A2:A" & Rows.Count)) = 0 Then GoTo son

    For i = 2 To SonStr Step 12

        ShtHdf.Range("A" & say & ":L" & say).Value = Application.Transpose(Sht.Range("A" & i & ":A" & i + 12).Value)

        say = say + 1

    Next

    MsgBox "bitti"

son:

      Application.ScreenUpdating = True

    Set Sht = Nothing: Set ShtHdf = Nothing

End Sub

sayin @berduş hocam kodunuzu biraz düzenledim.
Eğer son satır küçük 2 ise ekledim.
Ve en önemliside  ANA LİSTE sayfasında sadece A2 de veri olursa  For StrX = LBound(DiziKynk) To UBound(DiziKynk) bu satırda hata verirdi.

Sub ListeAktarDz()

    Dim SonStr As Long

    Dim Sht As Worksheet

    Dim ShtHdf As Worksheet

    Dim Dizi() As Variant

    Dim DiziKynk() As Variant

    Const sutun As Byte = 12

    

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

    Set ShtHdf = ThisWorkbook.Worksheets("SIRALAMA")

    

    ShtHdf.Range("A2", ShtHdf.Cells(Rows.Count, sutun)).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)

    

    i = 0

    For StrX = LBound(DiziKynk) To UBound(DiziKynk)

        Dizi(((StrX - 1) \ sutun), (StrX - 1) Mod sutun) = DiziKynk(StrX, 1)

    Next StrX

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

    

son:

    On Error Resume Next

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

    MsgBox "bitti"

End Sub

---

Çizgi içinde resimdeki gibi ilgilikodu ekleyin son koda.

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

Galiba her 38 satırda 1 çerçeve isteniyor

---

Geri dönüşü bekliyorum tam olarak ne istendiğini anlamak için

Kodu düzenledim. Const sutun As Byte = 12 burdaki 12 yerine ne gelirse o kadar sütun olur.
Benden bu kadar

Sub ListeAktarDz()

    Dim SonStr As Long

    Dim Sht As Worksheet

    Dim ShtHdf As Worksheet

    Dim Dizi() As Variant

    Dim DiziKynk() As Variant

    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

    

    StrSay = (SonStr - 1) \ sutun + 1

    ReDim Dizi(StrSay, sutun)

    DiziKynk = Sht.Range("A2:A" & SonStr)

    

    i = 0

    For StrX = LBound(DiziKynk) To UBound(DiziKynk)

        Dizi(((StrX - 1) \ sutun), (StrX - 1) Mod sutun) = DiziKynk(StrX, 1)

    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

Üye beğenmedi heralde bizi Halil hocam