öğrenci gruplandırma

Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
Merhaba arkadaşlar;

1. Yaklaşık 100 öğrencilik bir grubunda başarılı olan öğrenciler kamplara gönderilecektir.
2. En az özelikleri farklı 3 farklı kamp bulunmaktadır.
3. Her öğrenci kampları kendi içinde 1, 2, ve 3 tercihi olarak tercih edecek ve her kampın 12 kontenjanı bulunacaktır.
4. Yapılan bir sınav sonucuna göre en yüksek puan alan öğrenciden başlanarak öğrenciler tercih sırasına göre kamplara dağıtılacak, kamp kontenjan sayısı dolunca yedekler de belirlenecektir.

*Herhangi bir öğrenci en az bir en fazla kamp sayısı kadar tercih de bulunabilecektir.
* öğrenci sayısı, kamp sayısı ve kamp kontenjanı sayıları dönem dönem farklılık gösterebilir.

Konu ile ilgili makro, formül vb. yardımcı olursanız çok sevinirim. Teşekkürler...

Örnek dosya linki: https://yadi.sk/i/lI8PskKrICUSlA
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod eklemiş olduğunuz tercihler sayfasında çalıştırılmalıdır.
Soruda tercihler de sıfır ne anlama geliyor bilmiyorum
Bu kod sıfır hariç kamp1,kamp2,kamp3 sutunlarındaki tercih1,tercih2,tercih3 deki değerlerle dağıtım yapmaktadır.

Kod:
Sub asil_tercih()
Range(Cells(5, 8), Cells(Rows.Count, 10)).ClearContents
Range(Cells(3, 6), Cells(Rows.Count, 6)).ClearContents

For i = 3 To Cells(Rows.Count, 1).End(3).Row
For j = 3 To 5
sut = Cells(i, j).Value
say3 = Cells(i, j).Value
If say3 = 1 Then
say2 = 3
sut = 8
ElseIf say3 = 2 Then
say2 = 4
sut = 9
ElseIf say3 = 3 Then
say2 = 5
sut = 10
Else
GoTo atla1
End If

say4 = Cells(3, sut).Value

say1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range(Cells(5, sut), Cells(Rows.Count, sut)))
If say4 > say1 Then
Cells(say1 + 5, sut).Value = Cells(i, 1).Value
Cells(i, 6).Value = 1
Exit For
End If
atla1:
Next j

Next i

MsgBox "Asil işlem tamam"

End Sub


Sub yedek_tercih()

Range(Cells(5, 12), Cells(Rows.Count, 15)).ClearContents

son = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range(Cells(5, 8), Cells(Rows.Count, 10))) + 3
For i = 3 To Cells(Rows.Count, 1).End(3).Row

If Val(Cells(i, 6).Value) = 1 Then GoTo atla2


For j = 3 To 5
sut = Cells(i, j).Value
say3 = Cells(i, j).Value
If say3 = 1 Then
say2 = 3
sut = 13
ElseIf say3 = 2 Then
say2 = 4
sut = 14
ElseIf say3 = 3 Then
say2 = 5
sut = 15
Else
GoTo atla1
End If

say4 = Cells(3, sut).Value

say1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range(Cells(5, sut), Cells(Rows.Count, sut)))
If say4 > say1 Then
Cells(say1 + 5, sut).Value = Cells(i, 1).Value

Exit For
End If
atla1:
Next j
atla2:
Next i
Range(Cells(3, 6), Cells(Rows.Count, 6)).ClearContents
MsgBox "Yedek işlem tamam"

End Sub
 
Son düzenleme:
Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
Sıfır boş anlama geliyor, tercih yok, boş kalmasın diye sıfır yazdım.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
2 nolu mesajdaki kodu güncelledim.


Yeni Bit Eşlem Resmi.jpgYeni Bit Eşlem Resmi2.jpg
 
Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
Bu kod eklemiş olduğunuz tercihler sayfasında çalıştırılmalıdır.
Soruda tercihler de sıfır ne anlama geliyor bilmiyorum
Bu kod sıfır hariç kamp1,kamp2,kamp3 sutunlarındaki tercih1,tercih2,tercih3 deki değerlerle dağıtım yapmaktadır.

Kod:
Sub asil_tercih()
Range(Cells(5, 8), Cells(Rows.Count, 10)).ClearContents
Range(Cells(3, 6), Cells(Rows.Count, 6)).ClearContents

For i = 3 To Cells(Rows.Count, 1).End(3).Row
For j = 3 To 5
sut = Cells(i, j).Value
say3 = Cells(i, j).Value
If say3 = 1 Then
say2 = 3
sut = 8
ElseIf say3 = 2 Then
say2 = 4
sut = 9
ElseIf say3 = 3 Then
say2 = 5
sut = 10
Else
GoTo atla1
End If

say4 = Cells(3, sut).Value

say1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range(Cells(5, sut), Cells(Rows.Count, sut)))
If say4 > say1 Then
Cells(say1 + 5, sut).Value = Cells(i, 1).Value
Cells(i, 6).Value = 1
Exit For
End If
atla1:
Next j

Next i

MsgBox "Asil işlem tamam"

End Sub


Sub yedek_tercih()

Range(Cells(5, 12), Cells(Rows.Count, 15)).ClearContents

son = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range(Cells(5, 8), Cells(Rows.Count, 10))) + 3
For i = 3 To Cells(Rows.Count, 1).End(3).Row

If Val(Cells(i, 6).Value) = 1 Then GoTo atla2


For j = 3 To 5
sut = Cells(i, j).Value
say3 = Cells(i, j).Value
If say3 = 1 Then
say2 = 3
sut = 13
ElseIf say3 = 2 Then
say2 = 4
sut = 14
ElseIf say3 = 3 Then
say2 = 5
sut = 15
Else
GoTo atla1
End If

say4 = Cells(3, sut).Value

say1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range(Cells(5, sut), Cells(Rows.Count, sut)))
If say4 > say1 Then
Cells(say1 + 5, sut).Value = Cells(i, 1).Value

Exit For
End If
atla1:
Next j
atla2:
Next i
Range(Cells(3, 6), Cells(Rows.Count, 6)).ClearContents
MsgBox "Yedek işlem tamam"

End Sub
çalıştı teşekkür ederim. ama ufak bi kurgulama hatası yaptım.



örneğin öğrenciler sınav sonuçları büyükten küçüğe sıralandıktan sonra en yüksek puan alan öğrenci den başlanarak kamplara dağıtıldığında örneğin 1.kampın 2 kontenjanı varsa ; 80 ve 75 puan alan öğrenciler yerleşecek 70 puan alan öğrenci ikinci tercihi olan kampa yerleşecek.

* 1.kamp doldu ve sıradaki öğrencinin 1.kamp tercihi var bu öğrenciyi ikinci tercihi olan kampa yerleştirecek. diğer kamplar içinde bu şekilde olacak. hangi kamp dolarsa ve sıradaki öğrencilerden o kamp ta tercihi varsa 2 tercihi olan kampa yerleşecek. ikinci tercihinin olduğu kampta da doluysa üçüncü tercihine atanacak. yani yedek listesine gerek kalmayacak. yeni dosyayı ekte gönderiyorum.

Örnek dosya: https://yadi.sk/i/Op3TLNmwjkoWag
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kurgunuzda bir eksiklik yok demi örnek 9. sıradaki 5 öğrenci birinci tercihi 0 ikinci tercihi 1 üçüncü terciği 2
sıfırı boş geçersek birinci terciğini siz kap2 ye yazmışsınız
yazmış olduğum kod ile ilgili tercihlere bakarak sıfır hariç ona göre 1,2,3, yazan bölümlere aktarmaktadır.
 
Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
Kurgunuzda bir eksiklik yok demi örnek 9. sıradaki 5 öğrenci birinci tercihi 0 ikinci tercihi 1 üçüncü terciği 2
sıfırı boş geçersek birinci terciğini siz kap2 ye yazmışsınız
yazmış olduğum kod ile ilgili tercihlere bakarak sıfır hariç ona göre 1,2,3, yazan bölümlere aktarmaktadır.

sıfırı dikkate almıyoruz. olmasa da olur hücre boş kalmasın diye yazdımdı. o öğrencinin sadece 2 tercihi olmuş oluyor, 1 ve 2 yazan kamplar sıfır olanı tercih etmemiş oluyor.

* Bu şekilde öğrencilerin ilk tercihi hariç diğerleri ni dikkate almamış oluyoruz.

* örneğin benim tercih ettiğim ilk sıradaki kamp(1 nolu olan) doluysa ikinci tercihim olan (2 nolu) kampa yerleşecem, oda doluysa 3 numaralı kampa alınacam. bu şekilde kamplara yerleşmemiz gerekiyor.

* öğrencileri adaletli bir şekilde kamplara dağıtmak istiyorum. teşekkürler...

teşekkürler...
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
O zaman şöyle yapın birinci terciği sıfır olsun ikinci terciği iki olsun üçüncü terciği üç olsun böyle mantıkla yapılırsa olur herhalde
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kodun kurgusunda sıfır değerler ve diğerleri böyle olmalı.

Adsız1.jpg
 
Son düzenleme:

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Burada kod terciği yaparken Kamp 1,Kamp 2.Kamp 3 yazan değere bakmıyor C.D.E. sutunundaki 1,2,3 sayısına bakıyor
 
Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
Burada kod terciği yaparken Kamp 1,Kamp 2.Kamp 3 yazan değere bakmıyor C.D.E. sutunundaki 1,2,3 sayısına bakıyor
farklı kombinasyonlarla denedim hepsinde çalışıyor dediğim gibi teşekkür ederim. çok yardımcı oldunuz
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kontenjan için H3..I3.J3 Hücrelerindeki değerleri değiştirmeniz yeterli
Kamp sayısı için Kodu düzeltmek gerekecek çünkü sutun eklemek gerekecek
 
Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
öğrenci, kamp sayısı ve kontenjan değişikliğinde nasıl bir yol izlemem gerekecek
ben biraz bakayım koda değişiklik yapıp, sayıları artırıp . çok yardımcı oldunuz ... son olarak müsait zamanınızda kodun yanına açıklama yazarsanız bende rahatlıkla değiştirebilirim. teşekkürler
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
8 adet kontenjan için kod sayfaların ekran görüntüsünü de ekliyorum.

Kod:
Sub asil_tercih()

sayf1 = "Tercihler"
sayf2 = "kamp listesi"

Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, 2), Worksheets(sayf2).Cells(Rows.Count, 4)).ClearContents

For i = 3 To Worksheets(sayf1).Cells(Rows.Count, 1).End(3).Row
For j = 3 To Worksheets(sayf1).Cells(1, Columns.Count).End(xlToLeft).Column
sut1 = Worksheets(sayf1).Cells(i, j).Value
say3 = Worksheets(sayf1).Cells(i, j).Value
If say3 = 1 Then
sut1 = 2
sut2 = sut1 + 1
ElseIf say3 = 2 Then
sut1 = 3
sut2 = sut1 + 1
ElseIf say3 = 3 Then
sut1 = 4
sut2 = sut1 + 1
ElseIf say3 = 4 Then
sut1 = 5
sut2 = sut1 + 1
ElseIf say3 = 5 Then
sut1 = 6
sut2 = sut1 + 1
ElseIf say3 = 6 Then
sut1 = 7
sut2 = sut1 + 1
ElseIf say3 = 7 Then
sut1 = 8
sut2 = sut1 + 1
ElseIf say3 = 8 Then
sut1 = 9
sut2 = sut1 + 1
Else
GoTo atla1
End If

say4 = Worksheets(sayf1).Cells(1, sut2).Value
say1 = WorksheetFunction.CountA(Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, sut1), Worksheets(sayf2).Cells(Rows.Count, sut1)))
If say4 > say1 Then
Worksheets(sayf2).Cells(say1 + 4, sut1).Value = Worksheets(sayf1).Cells(i, 1).Value
Exit For
End If
atla1:
Next j
Next i

MsgBox "Asil işlem tamam"

End Sub
Adsız1.jpg

Adsız2.jpg
 
Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
8 adet kontenjan için kod sayfaların ekran görüntüsünü de ekliyorum.

Kod:
Sub asil_tercih()

sayf1 = "Tercihler"
sayf2 = "kamp listesi"

Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, 2), Worksheets(sayf2).Cells(Rows.Count, 4)).ClearContents

For i = 3 To Worksheets(sayf1).Cells(Rows.Count, 1).End(3).Row
For j = 3 To Worksheets(sayf1).Cells(1, Columns.Count).End(xlToLeft).Column
sut1 = Worksheets(sayf1).Cells(i, j).Value
say3 = Worksheets(sayf1).Cells(i, j).Value
If say3 = 1 Then
sut1 = 2
sut2 = sut1 + 1
ElseIf say3 = 2 Then
sut1 = 3
sut2 = sut1 + 1
ElseIf say3 = 3 Then
sut1 = 4
sut2 = sut1 + 1
ElseIf say3 = 4 Then
sut1 = 5
sut2 = sut1 + 1
ElseIf say3 = 5 Then
sut1 = 6
sut2 = sut1 + 1
ElseIf say3 = 6 Then
sut1 = 7
sut2 = sut1 + 1
ElseIf say3 = 7 Then
sut1 = 8
sut2 = sut1 + 1
ElseIf say3 = 8 Then
sut1 = 9
sut2 = sut1 + 1
Else
GoTo atla1
End If

say4 = Worksheets(sayf1).Cells(1, sut2).Value
say1 = WorksheetFunction.CountA(Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, sut1), Worksheets(sayf2).Cells(Rows.Count, sut1)))
If say4 > say1 Then
Worksheets(sayf2).Cells(say1 + 4, sut1).Value = Worksheets(sayf1).Cells(i, 1).Value
Exit For
End If
atla1:
Next j
Next i

MsgBox "Asil işlem tamam"

End Sub
Ekli dosyayı görüntüle 209033

Ekli dosyayı görüntüle 209034
Merhaba , bu kodu çalıştırdığımda öğrencilerin tercihleri 1 den başlayarak sıralı olursa çalışıyor. diğer durumlarda birinci kampta karışık olursa düzgün sonuç vermiyor. öğrencilerin tercihlerine bakarak yerleştirmeyi sadece 12345... şeklnde olursa kamplara düzgünce yerleştiriyor. Kolay gelsin
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Karışık olursa da kod düzgün çalışıyor mesela 51324 gibi kodun mantığını anlamadığınızı düşünüyorum.

örnrk i. tercih 0 yok - 2. tercih 0 yok -3.tercih 5 -4.tercih 3 -5.tercih 4 mantık bu siz kamp tercihleriyle bunu karıştırıyorsunuz.
başka bir örnek kişi sadece üçüncü tercihi seçsin diğerleri sıfır olsun ancak üçüncü tercihinde 5 yassın seçimi yaparken sırası ile bakıyır 1 tercih sıfır-2tercih sıfır - 3 tercih 5 olduğundan buna göre kod işlem yapmaktadır.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu resimdeki verileri irdeleyiniz özellikle tercih edilen sutun değerlerini

Kod:
Sub asil_tercih2()

sayf1 = "Tercihler"
sayf2 = "kamp listesi"

Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, 1), Worksheets(sayf2).Cells(Rows.Count, 9)).ClearContents

For i = 3 To Worksheets(sayf1).Cells(Rows.Count, 1).End(3).Row
For j = 3 To Worksheets(sayf1).Cells(1, Columns.Count).End(xlToLeft).Column
sut1 = Worksheets(sayf1).Cells(i, j).Value
say3 = Worksheets(sayf1).Cells(i, j).Value
If say3 = 1 Then
sut1 = 2
sut2 = sut1 + 1
ElseIf say3 = 2 Then
sut1 = 3
sut2 = sut1 + 1
ElseIf say3 = 3 Then
sut1 = 4
sut2 = sut1 + 1
ElseIf say3 = 4 Then
sut1 = 5
sut2 = sut1 + 1
ElseIf say3 = 5 Then
sut1 = 6
sut2 = sut1 + 1
ElseIf say3 = 6 Then
sut1 = 7
sut2 = sut1 + 1
ElseIf say3 = 7 Then
sut1 = 8
sut2 = sut1 + 1
ElseIf say3 = 8 Then
sut1 = 9
sut2 = sut1 + 1
Else
GoTo atla1
End If

say4 = Worksheets(sayf1).Cells(1, sut2).Value
say1 = WorksheetFunction.CountA(Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, sut1), Worksheets(sayf2).Cells(Rows.Count, sut1)))
If say4 > say1 Then
Worksheets(sayf2).Cells(say1 + 4, sut1).Value = Worksheets(sayf1).Cells(i, 1).Value
Worksheets(sayf2).Cells(say1 + 4, 1).Value = say1 + 1

Exit For
End If
atla1:
Next j
Next i

MsgBox "Asil işlem tamam"

End Sub
Yeni Bit Eşlem Resmi1.jpg

Yeni Bit Eşlem Resmi2.jpg
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu resimde de sıfır değerleri sildim sadece tercih sutunlarında veriler var irdeleyiniz.Yeni Bit Eşlem Resmi3.jpg

Yeni Bit Eşlem Resmi2.jpg
 
Katılım
17 Ekim 2017
Mesajlar
19
Excel Vers. ve Dili
başlangıç seviyesi
macro oluşturma
Bu resimdeki verileri irdeleyiniz özellikle tercih edilen sutun değerlerini

Kod:
Sub asil_tercih2()

sayf1 = "Tercihler"
sayf2 = "kamp listesi"

Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, 1), Worksheets(sayf2).Cells(Rows.Count, 9)).ClearContents

For i = 3 To Worksheets(sayf1).Cells(Rows.Count, 1).End(3).Row
For j = 3 To Worksheets(sayf1).Cells(1, Columns.Count).End(xlToLeft).Column
sut1 = Worksheets(sayf1).Cells(i, j).Value
say3 = Worksheets(sayf1).Cells(i, j).Value
If say3 = 1 Then
sut1 = 2
sut2 = sut1 + 1
ElseIf say3 = 2 Then
sut1 = 3
sut2 = sut1 + 1
ElseIf say3 = 3 Then
sut1 = 4
sut2 = sut1 + 1
ElseIf say3 = 4 Then
sut1 = 5
sut2 = sut1 + 1
ElseIf say3 = 5 Then
sut1 = 6
sut2 = sut1 + 1
ElseIf say3 = 6 Then
sut1 = 7
sut2 = sut1 + 1
ElseIf say3 = 7 Then
sut1 = 8
sut2 = sut1 + 1
ElseIf say3 = 8 Then
sut1 = 9
sut2 = sut1 + 1
Else
GoTo atla1
End If

say4 = Worksheets(sayf1).Cells(1, sut2).Value
say1 = WorksheetFunction.CountA(Worksheets(sayf2).Range(Worksheets(sayf2).Cells(4, sut1), Worksheets(sayf2).Cells(Rows.Count, sut1)))
If say4 > say1 Then
Worksheets(sayf2).Cells(say1 + 4, sut1).Value = Worksheets(sayf1).Cells(i, 1).Value
Worksheets(sayf2).Cells(say1 + 4, 1).Value = say1 + 1

Exit For
End If
atla1:
Next j
Next i

MsgBox "Asil işlem tamam"

End Sub
Ekli dosyayı görüntüle 209150

Ekli dosyayı görüntüle 209151
Merhaba, bu koda şöyle bi durum ekleyebilir miyiz. ilk öğrencinin tercihinde 1 yoksa 2,3,4 yazıyorsa 1'den değilde 2' nci tercihini ilk kabul etmesi.
Yani tercihleri içinde en küçük değeri baz alarak yerleştirme yapması.
 
Üst