• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Derse Göre Grup Oluşturma

B

beyinmuhendisi

Katılım
8 Temmuz 2011
Mesajlar
208
Excel Vers. ve Dili
TR, Office 2010
Epey uğraştım ama yapamadım. Ekli dosyada da belirttim. "Grupla" botonuna tıklayınca "C ve D" sütunu arasına sütun ekleyip istediğim şekilde biçimlendirdim. Ancak bundan sonrası beni aşıyor. İstediğimin bitmiş hali 2. sayfada mevcuttur. "Din Kültürü ve A. B." seçen öğrenci için tüm seçiği dersler için "1. GRUP", "Sosyal Bilgiler" seçen öğrenci için "2. GRUP", "Görsel Sanatlar" seçen öğrenci için "3. GRUP", "Beden Eğitimi" seçen öğrenci için "4. GRUP", "Müzik" seçen öğrenci için "5. GRUP" şeklinde olmalı. Yardımlarınız için teşekkür ederim. İyi çalışmalar.

Dosyayı güncelledim
 

Ekli dosyalar

Son düzenleme:
Farklı denemeler yaptığım için ekteki kod hatalı.
Geldiğim aşamada çalışan kod aşağıdaki gibi ama devamını ne yazık ki getiremedim.

Kod: 
Sub Grupla()
    ActiveSheet.Columns("D:D").Insert Shift:=xlToRight
    Columns("D:D").ColumnWidth = 12
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Seçilen Grup"
    Range("D1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
End Sub
 
Merhaba.

Kod güncellendi.
.
Kod: 
[B]Sub Grupla()[/B]
If Cells(1, 4) = "Seçilen Grup" Then Columns(4).Delete
Columns(4).Insert Shift:=xlToRight: [D1] = "Seçilen Grup"
For sat = 2 To Cells(Rows.Count, 1).End(3).Row
        Select Case Mid(Cells(sat, 3), 1, 3)
            Case "Din": grup = "1. GRUP"
            Case "Sos": grup = "2. GRUP"
            Case "Gör": grup = "3. GRUP"
            Case "Bed": grup = "4. GRUP"
            Case "Müz": grup = "5. GRUP"
            Case Else: GoTo 10
        End Select
ilk = WorksheetFunction.Match(Cells(sat, 1), Range("A:A"), 0)
son = ilk + WorksheetFunction.CountIf(Range("A:A"), Cells(sat, 1)) - 1
Range("D" & ilk & ":D" & son) = grup
10: Next: Columns(4).AutoFit: MsgBox "İşlem tamamlandı..."
[B]End Sub[/B]
 
Üstadım emeğiniz için teşekkür ederim. Elinize sağlık
2. mesajda doğru kodu göndermiştim; ancak sanırım siz öncesinde, dosyadaki kod ile çalıştınız.
Kodunuzu bozmamak adına müdahale etmek istemiyorum. Yazdığınız kod "sayfa2"ye de sütun ekliyor.
Kodu aktif sayfa olarak güncelleyebilir misiniz?
 
Sanırım böyle

Kod: 
Sub Grupla()
If ActiveSheet.[A1] <> "Öğrenci Adı ve Soyadı" Then GoTo 10
    ActiveSheet.Columns("D:D").Insert Shift:=xlToRight
    ActiveSheet.Columns("D:D").ColumnWidth = 12
    ActiveSheet.Range("D1") = "Seçilen Grup"
For sat = 2 To ActiveSheet.Cells(Rows.Count, 1).End(3).Row
    If ActiveSheet.Cells(sat, 1) <> ActiveSheet.Cells(sat - 1, 1) Then
        sayı = sayı + 1
        ActiveSheet.Cells(sat, 4) = sayı & ". GRUP"
    Else
        ActiveSheet.Cells(sat, 4) = ActiveSheet.Cells(sat - 1, 4)
    End If
Next
10: sayı = Empty
MsgBox "İşlem tamamlandı..."
End Sub
 
Üstadım döngü sağlamıyor.
Kod sıra ile devam ediyor.
Örneğin liste sonuna Sosyal Bilgiler seçen başka bir öğrenci eklendiğinde 2. Grup olması gerekirken 6. Grup oluyor.
Türkçe, Matematik, Fen Bilimleri ve Yabancı Dil dersleri her grupta ortak, grubu belirlerken bu dersler dışında kalan Din, Sosyal, Görsel, Beden ve Müzik dersine göre belirliyoruz
 
Tekrar merhaba.

Önceki cevabımdaki kod'u güncelledim.
Az önce olayı yanlış anlamışım.
Sayfayı yenileyerek önceki kod cevabıma tekrar bakınız.
.
 
Üstadım özür dilerim ben doğru anlatamadım galiba!

Son yazdığınız kodda;
Volkan İLERİ ... Türkçe - 1. GRP
Volkan İLERİ ... Matematik - 2. GRUP
Volkan İLERİ ... Fen B. - 3. GRUP
Volkan İLERİ ... Yabancı D. - 4. GRUP
Volkan İLERİ ... Görsel S. - 7. Grup

Olması Gereken,
Volkan İLERİ ... Türkçe - 3. GRP
Volkan İLERİ ... Matematik - 3. GRUP
Volkan İLERİ ... Fen B. - 3. GRUP
Volkan İLERİ ... Yabancı D. - 3. GRUP
Volkan İLERİ ... Görsel S. - 3. Grup

Şöyle ki;
Din seçenler - 1. Grup
Sosyal seçenler - 2. Grup
Görsel seçenler - 3. Grup
Beden seçenler - 4. Grup
Müzik seçenler - 5. Grup
olmalı

Volkan İLERİ, ayırıcı dersi "Görsel" seçtiği için Volkan'ın tüm derslerinin karşılığında 3. Grup yazmalı.
Teşekkür ederim!
 
Sayfayı yenileyerek önceki cevabımı tekrar kontrol eder misiniz?
A sütunundaki aynı isimlerin ardarda yer aldığını varsaydım.
 
Üstadım zahmet verdim. Aklınıza, emeğinize sağlık!
Aynı isimler dosyanın aslında da alt alta sanırım. Şuan tam istediğim gibi oldu. İyi çalışmalar diler, teşekkür ederim!
 
En iyisi alfabetik sıralamayı da garantiye almak için;
kod'un Sub Grupla() satırından sonra aşağıdaki satırı ekleyin.
Böylece işlem öncesinde A sütununa göre alfabetik sıralama yapılacaktır.
.
Kod: 
Range("A2:E" & Cells(Rows.Count, 1).End(3).Row).Sort , Key1:=[A1], Order1:=xlAscending
 
Dosya elime yeni geçti;
Daha karışık bir mantık var dosyada. Mantık kurmak zor gibi. Beş grubun haricinde bir grup da (Görsel, Beden ve Müzik) üç ders seçen öğrenciler var.
 
Son düzenleme:
Teşekkür ederim!
Yüzeysel baktım, hata veya eksik göremedim.
Elinize gönlünüze sağlık. İyi çalışmalar.
 
Selamlar yine ben!
:)

8. Sınıftan öğrenci ekleyince Din Kültürü dersi nedeni ile 8. sınıfları "6. GRUP" olarak göstermesi gerekirken "1. GRUP" olarak gösterdi. Bu sefer, T.C. İnkılap ayırıcı ders Din dersi ile çakıştı.
Ayrıca 8. Sınıflar 6 ders seçiyor

7. grup için yaptığınız uygulamayı denedim ama başaramadım.
 
Son düzenleme:
Tekrar merhaba.

Hangi sınıflar kaç ders seçiyor, hangi ders/dersler seçildiğinde hangi grup olarak adlandırılacak?
Sınıflar itibariyle GRUP numarası belirleme kriterlerini ayrıntılı yazmalısınız.

8 numaralı cevabınızdaki gibi net ve sınıf sınıf belirtirseniz, tekrar bakayım.
Kod'da Case "TC." kısmını Case "T.C" olarak değiştirin.
.
 
5, 6 ve 7. Sınıflar 5 ders
Bu sınıflardan bazı öğrenciler 3 ders (Görsel, beden, müzik)

8. Sınıflar 6 ders
1. grup (5, 6, 7. sınıflar) din ile 8. sınıf din çakışıyor. Bu nedenle 6. Grup göstermesi gerekirken 1. grup gösteriyor.
8. sınıfların ayırıcı dersi T.C. İnkılap
Din dersi 5, 6, 7 ve 8'de de var.

Farklı bir yol denedim. Görüş ve önerinizi almak için ektedir. Bana daha kullanışlı gibi geldi.
:)
 

Ekli dosyalar

Gruplandırma işlemini tam anlayamadım.

Sayfalara aktarma işlemini aşağıdaki gibi yapabilirsiniz.
(örnek olarak FEN BİLİMLERİ'ni yaptım, diğerlerini buna göre halledersiniz.)
.
Kod: 
[B]Sub AKTAR_[COLOR="Red"]FEN[/COLOR]()[/B]
Set s1 = Sheets("Sheet1"): Set hedef = Sheets("[B][COLOR="Red"]Fen[/COLOR][/B]")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
hedef.Range("A:D").ClearContents: son = s1.Cells(Rows.Count, 1).End(3).Row
s1.Range("A5:K5").AutoFilter Field:=7, Criteria1:="[B][COLOR="Red"]Fen Bilimleri[/COLOR][/B]"
    s1.Range("D5:E" & son).SpecialCells(xlCellTypeVisible).Copy hedef.[A1]
    s1.Range("G5:G" & son).SpecialCells(xlCellTypeVisible).Copy hedef.[C1]
    s1.Range("A5:A" & son).SpecialCells(xlCellTypeVisible).Copy hedef.[D1]
    s1.ShowAllData
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "[B][COLOR="red"]Fen Bilimleri[/COLOR][/B] sayfasına veriler aktarıldı."
[B]End Sub[/B]
 
Aşağıdaki kod düzelmeden çalışma tamamlanmayacak üstadım.

En son şöyle anlatabilirim.

Görsel, Müzik ve Beden seçince "7. grup" olarak yazdığınız kodun benzerini
T.C. İnkılap ve Din Kült. birlikte seçen öğrenciler için "6. grup" olarak düzenlememiz gerekiyor.

Kod: 
Sub Grupla()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If Cells(5, "H") = "Seçilen Grup" Then Columns("H").Delete
sonsat = Cells(Rows.Count, 1).End(3).Row
Range("B6:C" & sonsat).UnMerge
Range("I6:J" & sonsat).UnMerge
Range("A6:J" & sonsat).Sort , Key1:=[E5], Order1:=xlAscending
Columns("H:H").Insert Shift:=xlToRight: [H5] = "Seçilen Grup"
    beden = "Beden Eğitimi ve Spor": görsel = "Görsel Sanatlar": müzik = "Müzik"
For sat = 6 To sonsat
isat = sat + WorksheetFunction.CountIf(Range("E:E"), Cells(sat, "E")) - 1

If WorksheetFunction.CountIf(Range("G" & sat & ":G" & isat), beden) + _
    WorksheetFunction.CountIf(Range("G" & sat & ":G" & isat), görsel) + _
    WorksheetFunction.CountIf(Range("G" & sat & ":G" & isat), müzik) = 3 Then
    grup = "7. GRUP": Range("H" & sat & ":H" & isat) = grup: sat = isat
Else
    Select Case Mid(Cells(sat, 7), 1, 3)
        Case "Din": grup = "1. GRUP"
        Case "Sos": grup = "2. GRUP"
        Case "Gör": grup = "3. GRUP"
        Case "Bed": grup = "4. GRUP"
        Case "Müz": grup = "5. GRUP"
        Case "T.C": grup = "6. GRUP"
        Case Else: GoTo 10
    End Select
    ilk = WorksheetFunction.Match(Cells(sat, 5), Range("E:E"), 0)
    son = ilk + WorksheetFunction.CountIf(Range("E:E"), Cells(sat, 5)) - 1
    Range("H" & ilk & ":H" & son) = grup: sat = son
End If
10: Next
For ssat = 6 To sonsat
    Range(Cells(ssat, "B"), Cells(ssat, "C")).Merge
    Range(Cells(ssat, "J"), Cells(ssat, "K")).Merge
Next
Range("B6:D" & sonsat).HorizontalAlignment = xlCenter
Range("F6:F" & sonsat).HorizontalAlignment = xlRight
Range("H6:H" & sonsat).HorizontalAlignment = xlCenter
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Columns("A:K").AutoFit: MsgBox "İşlem tamamlandı..."
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst