Derse göre gruplandırma

[faruk588]

Öğrencileri aldıkları derse göre gruplandırmak istedim ama indis le yapamadım. Bir yolu var mı acaba? Vakit ayıran arkadaşlara şimdiden teşekkürler.

 

[Orion1]

Dosyanız ektedir.

Sub gruplama_59()
Dim i As Long, sut As String, sat1 As Long, sat2 As Long
Sheets("Sayfa1").Select
Range("E2:G65536").ClearContents
Application.ScreenUpdating = False
sat1 = Cells(65536, "A").End(xlUp).Row
For i = 2 To sat1
    If Cells(i, "C").Value = "T.M" Then sut = "E"
    If Cells(i, "C").Value = "MAT" Then sut = "F"
    If Cells(i, "C").Value = "FEN" Then sut = "G"
    sat2 = Cells(65536, sut).End(xlUp).Row + 1
    Cells(sat2, sut).Value = Cells(i, "A").Value & " " & Cells(i, "B").Value
    sat2 = sat2 + 1
Next i
Application.ScreenUpdating = True
MsgBox "Gruplama tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[faruk588]

Abi süper güzel birşey hazırlamışsın. Ellerine sağlık. Ama sadece merak ettiğim için diğer arkadaşlara da sormak istiyorum acaba daha kolay bir yolu yok muydu?

 

[muygun]

Merhaba;
İşlevlerle çözülmüş bir alternatif.
İyi çalışmalar.

 

[faruk588]

Bu formülleri yazmak ve düşünmekte bir yetenek. Ben hayretle karşılıyorum. :bravo:

 

[faruk588]

Evren Gizlen' in verdiği kodu uyarlamak istedim ama bir hata oldu bu fomülde hata nerede acep arkadaşlar.

Sub Aktar()
Dim i As Long, sut As String, sat1 As Long, sat2 As Long
Sheets("TASIMA PROGRAMI").Select
Range("AA2:AD655536").ClearContents
Application.ScreenUpdating = False
sat1 = Cells(65536, "W").End(xlUp).Row
For i = 2 To sat1
If Cells(i, "Z").Value = "T.M" Then sut = "AA"
If Cells(i, "Z").Value = "FEN" Then sut = "AB"
If Cells(i, "Z").Value = "MAT" Then sut = "AC"
If Cells(i, "Z").Value = "SERBEST" Then sut = "AD"
sat2 = Cells(655536, sut).End(xlUp).Row + 2
Cells(sat2, sut).Value = Cells(i, "W").Value & " " & Cells(i, "X").Value
sat2 = sat2 + 1
Next i
Application.ScreenUpdating = True
MsgBox "Gruplama tamamlanmıştır." & vbLf & _
"www..com", vbOKOnly + vbInformation, "OK"
End Sub