• DİKKAT

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

kura çekme

M

mutluedenercan

Katılım
9 Aralık 2009
Mesajlar
532
Excel Vers. ve Dili
2007,5
Okulumuzda 300 - 400 arası tahminen 1. sınıfa başlıyacak öğrenci var

ekteki dosyada olduğu gibi

kız ve erkek öğrencileri ayrı stunlara gireceğiz, bunları 8 sınıfa ayıracağız
(seçim rastgele olacak bir kız bir erkek listesinden alacak ki sınıflarda kız erkek
öğrenci sayısı eşit olsun)

bir buton olacak ve basınca başlıyacak

Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 1. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 2. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 3. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 4. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 5. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 5. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 6. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 7. şubuye
Karışık olarak rastgele bir kız , bir erkek öğrenci alıp 8. şubuye


böyle böyle listeden karışık olarak alınan bir kız bir erkek öğrenci sıra ile şubelere atılacak

Listeden alınan öğrenci silinsinki birdaha aynı öğrenci alınmasın
şubelerin üzerine tıklayınca, o şubeye atılan öğrencilerin listesini alalım

bu liste bitene kadar şubelere atılma devem edecek

görsel olarak görülmeli
yani isimler ekranta taranıyormuş gibi 3-5 saniye görünecek şekilde geçip
sonra gittiği şube gözükmeli

olabilirmi

teşekkürler
 

Ekli dosyalar

Merhaba,

Birşeyler yapmaya çalıştım, inceler misiniz?

Kod: 
Option Base 1
Sub Dagit()
    Dim c       As Range, _
        i       As Integer, _
        j       As Integer, _
        Sube(8) As Integer, _
        K_Kalan As Integer, _
        E_Kalan As Integer, _
        Kalan   As Integer, _
        Satir   As Integer
    
    K_Kalan = Cells(Rows.Count, "B").End(3).Row - 1
    E_Kalan = Cells(Rows.Count, "A").End(3).Row - 1
    If E_Kalan > K_Kalan Then
        Kalan = E_Kalan
    Else
        Kalan = K_Kalan
    End If
    
    Range("C2:J" & E_Kalan).ClearContents
    
    For i = 1 To 8
        Sube(i) = 1
    Next i
    
    j = 0
    For i = Kalan To 0 Step -1
        j = j + 1
        If j > 8 Then j = 1
        If E_Kalan > 0 Then
            Randomize
            Satir = Int((E_Kalan * Rnd) + 1) + 1
            Range("A" & Satir).Activate
            Range("A" & Satir).Interior.ColorIndex = 3
            Application.Wait (Now + TimeValue("0:00:01"))
            Range("A" & Satir).Interior.ColorIndex = 5
            Application.Wait (Now + TimeValue("0:00:01"))
            
            Sube(j) = Sube(j) + 1
            Cells(Sube(j), j + 2) = Cells(Satir, "A")
            Range("A" & Satir).Delete Shift:=xlUp
            E_Kalan = E_Kalan - 1
        End If
        
        If K_Kalan > 0 Then
            Randomize
            Satir = Int((K_Kalan * Rnd) + 1) + 1
            Range("B" & Satir).Activate
            Range("B" & Satir).Interior.ColorIndex = 3
            Application.Wait (Now + TimeValue("0:00:01"))
            Range("B" & Satir).Interior.ColorIndex = 5
            Application.Wait (Now + TimeValue("0:00:01"))
            
            Sube(j) = Sube(j) + 1
            Cells(Sube(j), j + 2) = Cells(Satir, "B")
            Range("B" & Satir).Delete Shift:=xlUp
            K_Kalan = K_Kalan - 1
        End If
        
    Next i
    
    MsgBox "Dağıtım Tamamlanmıştır....", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr"]www.excel.web.tr[/URL]"
    
End Sub
 

Ekli dosyalar

Sn Necdet bey,

Benim konum değil fakat işime çok yaradı bu kodlar. O kadar güzel yapmışsınız ki inanın daha güzeli olamazdı. Emeğinize sağlık.
Teşekkürler...
 
Sayın mrs303,

İşinize yaradığına sevindim.
İyi günler dilerim.
 
Necdet bey, güzel çalışma gerçekten. Emeğinize sağlık.
Çok küçük bir katkı yapmak istiyorum, müsade ederseniz.
Değişken tanımlarının altına bir
Kod: 
Randomize
girer isek her çalıştırmada farklı sonuçlar elde edebiliriz.
Mutlaka ki biliyorsunuzdur ama gözden kaçabilir diye katkıda bulunmak istedim.
Teşekkürler.
 
lark' Alıntı:
Necdet bey, güzel çalışma gerçekten. Emeğinize sağlık.
Çok küçük bir katkı yapmak istiyorum, müsade ederseniz.
Değişken tanımlarının altına bir
Kod: 
Randomize
girer isek her çalıştırmada farklı sonuçlar elde edebiliriz.
Mutlaka ki biliyorsunuzdur ama gözden kaçabilir diye katkıda bulunmak istedim.
Teşekkürler.
Genişletmek için tıkla ...

Teşekkürler,

Dün kodları yazarken aklımdaydı ama asıl mantık üzerinde düşünürken onu unutmuşum, anımsattığınız için teşekkürler, kodları yenileyim.

Not : Kodlar ve dosya yenilenmiştir.
 
Çok iyi elinize emeğinize sağlık

Yanlız liste 300 lere uzanacak ya...
seçim yaparken şubeler devamlı ekranda kalabilirmi
yani 40. 120. gibi seçimi yaparken ekran aşağı kayınca şubeler ekrandan kayboluyor..
şubuler ve giren isimler devamlı ekranda kalabilirmi

teşekkür
 
mutluedenercan' Alıntı:
Çok iyi elinize emeğinize sağlık

Yanlız liste 300 lere uzanacak ya...
seçim yaparken şubeler devamlı ekranda kalabilirmi
yani 40. 120. gibi seçimi yaparken ekran aşağı kayınca şubeler ekrandan kayboluyor..
şubuler ve giren isimler devamlı ekranda kalabilirmi

teşekkür
Genişletmek için tıkla ...
hocam sanırım bundan bahsetmişsiniz...
 

Ekli dosyalar

başlıkları kalıyor sadece istiyorum ki

şube başlıkları kaldığı gibi o şubeye giren isimlerde devamlı kalsın
yani listenin altından seçerken ekrandaki şube isimleri ve listeleri kaybolmasın

bu zor ise tam terside yapılabir...
yani şube listeleri ekranda sabit görünür kalırken seçim yapılan liste kayabilir

hangisi olursa yeterki seçim yapılan liste ve o anda şubede olanlar aynı anda gözüksün
 
kusura bakmayın anlayamadım örnek üzerinde anlatırsanız belki daha açıklayıcı olur.........
 
Liste restgele seçilirken (exel sayfası 32 satır ı gösteriyor gerisini kaydırarak görebiliyoruz)

32. satırdan sonrakileri seçerken ( 300 - 400 satır olacak bizimki)

alta kayıyor haliyle
Bizim şubelere girenler ekrandan kayboluyor..

ekranda kalabilrmi
 
görsel kura çekimi

Değerli arkadaşlar ve Hocalarım...

önceki eklediğim kura çekimi, projeksiyon yansımasında farkedilmeyeceği için
bağzı yenikler ile yeni konu açmaya gerek duydum...çok değişiklik olacak çünkü

eklediğim sayfada erkek listesi solda, kız sağda, her ikisininde seçim ekranı ortadadır
1A - 1H ye kadar 8 şube butonları altındadır.

1- başla butonuna basınca, her şubeye bir erkek listesinden bir kız listesinden
öğrenci atacak, attığı öğrenciyi listeden silecek

2 - görsellik önemli, görenler karışık seçildiğini görmeleri açısından,
listelerden karışık seçilirken, seçilen isim renk değiştirmeli ve aynı anda
erkek ise, erkek ekranında ismi büyük olarak gözükmeli, bu isim ekranda iken
gideceği şube örneğin 1A düğmesi renk değişmeli; bu arada kız listesinden rastgele tarama başlamalı ve bir isimde durmalı( tabi taraken ve durunca o isim
renk değişmeli) seçilen isim kız ekranında büyük olarak gözükmeli

( şu halde, erkek listesi tarandı ekranda seçilen isim belirdi, gittiği şubenin rengi
yanıp sönüyor veya rengi diğerlerinden farklı; gittiği şubenin yanıpsönmesi devam ederken, ekranda hala seçilen erkek ismi dururken, kız listesi taraması başlamalı, saçilen isim rengi değişken ve aynı andada kız seçim ekranında büyük gözüküyor...yani bir erkek bir kız ismi ekranda büyük halde belirdi
ve gittiği şube yanıpsöndüğü için o kız ve erkeğin hanği şubeye gittiği belli oldu)
3 - buşekilde sıra 1B şubesine geldi; 1B düğmesi yanıp sönmeye veya olamıyorsa renk değiştirdi; listelerin taraması başladı ( listeler aynı andada taranabilir) kız ve erkek ekranlarına seçilen isimler belirdi. Gittiği şube yanıp söndüğü için belli zaten

4 - Taramalar görünsün o anda taranan isin belirgin olması, kaç saniye taranacak ve seçecek ( bu süreyi ben nereden değişeceğimi bilmeliyim)
seçilen ve büyük ekranda gözüken isimler kaç saniye bekleyip yeni taramaya geçecek ( yerini bilirsem değiştiririm)

5 - en sonunda listeler tükenince , tarama bitti mesajını alınca

1A ya tıklayınca 1a sayfasına gidip oraya atılanların listesini almalıyız

Teşekkürler ............
 

Ekli dosyalar

necdet bey bunca yıl sonra yazdıgınız kodlar işime yaradı çok teşekkurler
 
seçimi rasgele yapan kod hangisi ....

3-4 kez deneme yaptım bir isme dikkat ettim denemelerimin hepsinde o ismi aynı şubede gördüm

seçimi belli sırayagöremi yopıyor hocam
 
mutluedenercan' Alıntı:
seçimi rasgele yapan kod hangisi ....

3-4 kez deneme yaptım bir isme dikkat ettim denemelerimin hepsinde o ismi aynı şubede gördüm

seçimi belli sırayagöremi yopıyor hocam
Genişletmek için tıkla ...

Rasgele yapıyor. Bende denedim aynı isimler değişik sınıflara yerleşti.
Kodların son halini kullandığınızdan emin olunuz.
 
Hocam bana gönderdiğiniz , kodlar son hali deyilmi zeten ( birkez gönderdiniz onu aldım ondan sonra ikinci kez gönderilmedi)

hocam görsel olanı eklemiştim..görüntü büyük olsun diye okudunuzmu
--------------------------------------------------------
Değerli arkadaşlar ve Hocalarım...

önceki eklediğim kura çekimi, projeksiyon yansımasında farkedilmeyeceği için
bağzı yenikler ile yeni konu açmaya gerek duydum...çok değişiklik olacak çünkü

eklediğim sayfada erkek listesi solda, kız sağda, her ikisininde seçim ekranı ortadadır
1A - 1H ye kadar 8 şube butonları altındadır.

1- başla butonuna basınca, her şubeye bir erkek listesinden bir kız listesinden
öğrenci atacak, attığı öğrenciyi listeden silecek

2 - görsellik önemli, görenler karışık seçildiğini görmeleri açısından,
listelerden karışık seçilirken, seçilen isim renk değiştirmeli ve aynı anda
erkek ise, erkek ekranında ismi büyük olarak gözükmeli, bu isim ekranda iken
gideceği şube örneğin 1A düğmesi renk değişmeli; bu arada kız listesinden rastgele tarama başlamalı ve bir isimde durmalı( tabi taraken ve durunca o isim
renk değişmeli) seçilen isim kız ekranında büyük olarak gözükmeli

( şu halde, erkek listesi tarandı ekranda seçilen isim belirdi, gittiği şubenin rengi
yanıp sönüyor veya rengi diğerlerinden farklı; gittiği şubenin yanıpsönmesi devam ederken, ekranda hala seçilen erkek ismi dururken, kız listesi taraması başlamalı, saçilen isim rengi değişken ve aynı andada kız seçim ekranında büyük gözüküyor...yani bir erkek bir kız ismi ekranda büyük halde belirdi
ve gittiği şube yanıpsöndüğü için o kız ve erkeğin hanği şubeye gittiği belli oldu)
3 - buşekilde sıra 1B şubesine geldi; 1B düğmesi yanıp sönmeye veya olamıyorsa renk değiştirdi; listelerin taraması başladı ( listeler aynı andada taranabilir) kız ve erkek ekranlarına seçilen isimler belirdi. Gittiği şube yanıp söndüğü için belli zaten

4 - Taramalar görünsün o anda taranan isin belirgin olması, kaç saniye taranacak ve seçecek ( bu süreyi ben nereden değişeceğimi bilmeliyim)
seçilen ve büyük ekranda gözüken isimler kaç saniye bekleyip yeni taramaya geçecek ( yerini bilirsem değiştiririm)

5 - en sonunda listeler tükenince , tarama bitti mesajını alınca

1A ya tıklayınca 1a sayfasına gidip oraya atılanların listesini almalıyız

Teşekkürler ............
 

Ekli dosyalar

Sayın Necdet Yeşertener şube sayılarını arttırmak veya azaltmak için ne yapmamamız gerekiyor. Bizim okulda 3 tane şube olacak. Bu konuda yardımcı olursanız sevinirim.
 
zyrec' Alıntı:
Sayın Necdet Yeşertener şube sayılarını arttırmak veya azaltmak için ne yapmamamız gerekiyor. Bizim okulda 3 tane şube olacak. Bu konuda yardımcı olursanız sevinirim.
Genişletmek için tıkla ...

Aşağıdaki kodda koyu kırmızı olan değer şube sayısını ifade etmektedir.

Option Base 1
Sub Dagit()
Dim c As Range, _
i As Integer, _
j As Integer, _
Sube(8) As Integer, _
K_Kalan As Integer, _
E_Kalan As Integer, _
Kalan As Integer, _
Satir As Integer

K_Kalan = Cells(Rows.Count, "B").End(3).Row - 1
E_Kalan = Cells(Rows.Count, "A").End(3).Row - 1
If E_Kalan > K_Kalan Then
Kalan = E_Kalan
Else
Kalan = K_Kalan
End If

Range("C2:J" & E_Kalan).ClearContents

For i = 1 To 3
Sube(i) = 1
Next i

j = 0
For i = Kalan To 0 Step -1
j = j + 1
If j > 3 Then j = 1
If E_Kalan > 0 Then
Randomize
Satir = Int((E_Kalan * Rnd) + 1) + 1
Range("A" & Satir).Activate
Range("A" & Satir).Interior.ColorIndex = 3
Application.Wait (Now + TimeValue("0:00:01"))
Range("A" & Satir).Interior.ColorIndex = 5
Application.Wait (Now + TimeValue("0:00:01"))

Sube(j) = Sube(j) + 1
Cells(Sube(j), j + 2) = Cells(Satir, "A")
Range("A" & Satir).Delete Shift:=xlUp
E_Kalan = E_Kalan - 1
End If

If K_Kalan > 0 Then
Randomize
Satir = Int((K_Kalan * Rnd) + 1) + 1
Range("B" & Satir).Activate
Range("B" & Satir).Interior.ColorIndex = 3
Application.Wait (Now + TimeValue("0:00:01"))
Range("B" & Satir).Interior.ColorIndex = 5
Application.Wait (Now + TimeValue("0:00:01"))

Sube(j) = Sube(j) + 1
Cells(Sube(j), j + 2) = Cells(Satir, "B")
Range("B" & Satir).Delete Shift:=xlUp
K_Kalan = K_Kalan - 1
End If

Next i

MsgBox "Dağıtım Tamamlanmıştır....", vbInformation, "N. YEŞERTENER --> www.excel.web.tr"

End Sub
 
mutluedenercan' Alıntı:
Hocam bana gönderdiğiniz , kodlar son hali deyilmi zeten ( birkez gönderdiniz onu aldım ondan sonra ikinci kez gönderilmedi)

hocam görsel olanı eklemiştim..görüntü büyük olsun diye okudunuzmu
Genişletmek için tıkla ...


Keşke bu sorunuzu ilk sorunuzda belirtseydiniz.

Yeteri kadar zamanım yok, aynı şeyler için tekrar uğraşmak istemiyorum.
Bir arkadaşım umarım yardımcı olur.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst