Satır Sütun yer degiştirme ve tekrar etme

[yakup123]

arkadaşlar ekteki dosyada sınıf ders ve öğrencileri içeren bir dosya var ben satır sütunların yer değişmesini istiyorum ama her sınıf ve dersin her öğrenci için tekrar yazması lazım bu sekilde 3000 kaydım var ekte örnek belirttim yardımlarınız için teşekkür ederim

 

[İhsan Tank]

arkadaşlar ekteki dosyada sınıf ders ve öğrencileri içeren bir dosya var ben satır sütunların yer değişmesini istiyorum ama her sınıf ve dersin her öğrenci için tekrar yazması lazım bu sekilde 3000 kaydım var ekte örnek belirttim yardımlarınız için teşekkür ederim

Merhaba
Nerede yapılacağını söylememişsiniz bende Sayfa2'ye yaptırdım.
Kodu boş bir module kopyalayın ve deneyin.

Option Explicit
Sub değiştir_61()
Dim ts, kaplan, trabzonspor, asi, hamsi As Date
Dim bordo, mavi
Set bordo = Sheets("Sayfa1")
Set mavi = Sheets("Sayfa2")
trabzonspor = MsgBox("Verileri Değiştiriyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
mavi.Range("A2:C" & Rows.Count).ClearContents
For ts = 2 To bordo.Cells(Rows.Count, "A").End(xlUp).Row
For asi = 3 To bordo.Cells(ts, 256).End(xlToLeft).Column
trabzonspor = mavi.Range("A" & Rows.Count).End(xlUp).Row
mavi.Range("A" & trabzonspor + 1) = bordo.Cells(ts, "A")
mavi.Range("B" & trabzonspor + 1) = bordo.Cells(ts, "B")
If bordo.Cells(ts, asi) <> Empty Then
mavi.Range("C" & trabzonspor + 1) = bordo.Cells(ts, asi)
End If
Next
Next
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sürede Verileri Değiştirdim", , "Bitiş"
End Sub

 

[yakup123]

ihsan bey çok teşekkür ederim işimi gördü çok sağolun

 

[İhsan Tank]

ihsan bey çok teşekkür ederim işimi gördü çok sağolun

Rica ederim
:keyif: