Çekiliş makrosu

[erectus]

Merhabalar forumun tekrar açılmasına çok sevindim. Sürekli girip bir şeyler öğrenebildiğim bir platformun geçici de olsa kapanması kötü olmuştu.

A1 hücresinden başlayıp aşağıya doğru giden bir listede yer alan isimlerle çeliş yapmak istiyorum. Yani butona tıkladığımda şanslı kişi (hücredeki isim) gelsin istiyorum. Ancak bu çekiliş rastgele olmasın, listedeki herkes tamamlana kadar aynı kişi tekrar seçilemesin.

Sınıfta söz hakkı almak isteyen öğrenciler için kullanacağım.

Yardımlarınız için teşekkür ederim.

 

[leumruk]

Sub SayıÜret()
Randomize
MyNumber = Int(([COLOR="Red"]30[/COLOR] - 1 + 1) * Rnd + 1)
Range("A2") = (MyNumber)
Sat = Cells(31, "K").End(3).Row + 1
Cells(Sat, "K").Value = Range("A2")
If Range("A1") = 2 Then
Cells(Sat, "K").Value = ""
Range("A2") = ""
Call SayıÜret
If Range("K31") = [Sayfa1!A2] Then
MsgBox "Tüm öğrenciler bir defa seçildi. Seçim sıfırlanıyor..."
Range("K2:K31") = ""
Exit Sub
End If
End If
End Sub

Selamlar...
Sanırım böyle bir şey istiyorsunuz. İstediğiniz gibi Kura çekiyor ve isim seçiyor. Tüm öğrenciler tamamlanmadan ikinci defa aynı öğrenciyi seçmiyor. 30 kişilik bir öğrenci grubu için düzenledim. Siz sayıyı kendi sınıf sayınıza göre düzenleyebilirsiniz. Koddaki kırmızı kısım öğrenci sayısını belirtiyor.

 

[Levent Menteşoğlu]

Ekli dosyayı inceleyin.

 

[erectus]

Leumruk ve Levent Bey, ikinize de sonsuz teşekkürler. Ellerinize sağlık.

 

[erectus]

Heyecan

Şimdi aklıma geldi, heyacan açısından orada 5-6 saniye farklı isimlerin hızlı hızlı geçip, sonra bir isimde durması mümkün müdür acaba?

 

[erectus]

Şimdi aklıma geldi, heyacan açısından orada 5-6 saniye farklı isimlerin hızlı hızlı geçip, sonra bir isimde durması mümkün müdür acaba?

Arkadaşlar böyle bir şey mümkün mü? Mümkünse nasıl yapabiliriz? Yarın deneyeceğim bu kodu, mümkünse yardımcı olabilirseniz, sevinirim.

 

[Levent Menteşoğlu]

Ekli dosyaya istediğiniz gibi bir ilave yaptım. İsimlerin geçiş sayısını ve hızını ilk döngülerin üst limitleri olan 50 ve 6000 sayılarını değiştirerek elde edebilirsiniz.

 

[erectus]

Çok teşekkür ederim Levent Bey, harika olmuş.

 

[leumruk]

Şimdi aklıma geldi, heyacan açısından orada 5-6 saniye farklı isimlerin hızlı hızlı geçip, sonra bir isimde durması mümkün müdür acaba?

Syn. Erectus,
Dosyayı inceleyiniz.

Sub SayıÜret()
Randomize
MyNumber = Int((30 - 1 + 1) * Rnd + 1)
Range("A2") = (MyNumber)
Exit Sub
End Sub

Sub KuraÇek()
If Range("K31").Value <> "" And Range("A1") <> 2 Then
MsgBox "Tüm öğrenciler bir defa seçildi. Seçim sıfırlanıyor..."
Range("K2:K31") = ""
Exit Sub
Else:
Range("C1") = Range("C1") + 1
If Range("C1") = [COLOR="Cyan"]5 [/COLOR]Then
Sat = Cells(31, "K").End(3).Row + 1
Cells(Sat, "K").Value = Range("A2")
If Range("A1") <> 2 Then
MsgBox "Öğrenci seçildi..."
Range("C1") = ""
Else:
Son = Cells(31, "K").End(3).Row
Cells(Son, "K").Value = ""
Range("A2") = ""
Range("C1") = ""
Call KuraÇek
End If
Exit Sub
Else:
If Range("K31") = "" Then
Dim Say, Start, Ende, Gesamtdauer
[COLOR="Red"]Say = 0.2[/COLOR]
Start = Timer
Call SayıÜret
Do While Timer < Start + Say
DoEvents
Loop
Ende = Timer
Gesamtdauer = Ende - Start
Call KuraÇek
End If
End If
End If
Exit Sub
End Sub

UYARI: Kırmızı kısım, her ismin bekleme süresini gösteriyor;bu bölgeden süreyi artırabilir veya azaltabilirsiniz. Mavi kısım, kura sırasında geçen isim sayısı; daha fazla ismi çevirmesini isterseniz, burayı da artırabilirsiniz.
Sonlara doğru seçim yavaşlayabilir; çünkü öğrencilerin tekrar seçilmemesini istemişsiniz.

 

[Levent Menteşoğlu]

Sn leumruk güzel bir örnek olmuş tebrik ederim.

 

[leumruk]

Sn leumruk güzel bir örnek olmuş tebrik ederim.

Sizlerin sayesinde hocam... Teşekkür ederim...

 

[conkz]

Ekli dosyaya istediğiniz gibi bir ilave yaptım. İsimlerin geçiş sayısını ve hızını ilk döngülerin üst limitleri olan 50 ve 6000 sayılarını değiştirerek elde edebilirsiniz.

Merhaba,

Makrolarla pek bilgim olmadığı için soruyorum. Bu makro A sütununun tamamına 12000 satırlık bir veri girdiğimde de çalışır mı? Bir de benim şöyle bir durumum var. Elimde mesela 10 kişi var, ama A kişisinin 10 çekiliş hakkı varken B kişisinin 40 çekiliş hakkı var gibi bir durum. Ben bunu A sütununa 10 kere A, 40 kere B yazarak halletmeyi düşünüyordum. Sizce bunu kullanmam uygun olur mu?

 

[dgdizayn]

Merhabalar,

Tüm dosyayı indirdim fakat çekiliş olan dosyalar çalışmıyor. Sorun olan kısım örneğin 1. sıra Ali geldi 2. sıra Ahmet geldi 3. Sıra Mehmet geleceği yerine birinci sıraya geliyor. Tüm dosyaları denedim malesef bu şekilde çıkıyor. Kodları düzeltmeniz mümkün mü acaba. Teşekkürler.

 

[istanbulcahan]

Syn. Erectus,
Dosyayı inceleyiniz.

Sub SayıÜret()
Randomize
MyNumber = Int((30 - 1 + 1) * Rnd + 1)
Range("A2") = (MyNumber)
Exit Sub
End Sub

Sub KuraÇek()
If Range("K31").Value <> "" And Range("A1") <> 2 Then
MsgBox "Tüm öğrenciler bir defa seçildi. Seçim sıfırlanıyor..."
Range("K2:K31") = ""
Exit Sub
Else:
Range("C1") = Range("C1") + 1
If Range("C1") = [COLOR="Cyan"]5 [/COLOR]Then
Sat = Cells(31, "K").End(3).Row + 1
Cells(Sat, "K").Value = Range("A2")
If Range("A1") <> 2 Then
MsgBox "Öğrenci seçildi..."
Range("C1") = ""
Else:
Son = Cells(31, "K").End(3).Row
Cells(Son, "K").Value = ""
Range("A2") = ""
Range("C1") = ""
Call KuraÇek
End If
Exit Sub
Else:
If Range("K31") = "" Then
Dim Say, Start, Ende, Gesamtdauer
[COLOR="Red"]Say = 0.2[/COLOR]
Start = Timer
Call SayıÜret
Do While Timer < Start + Say
DoEvents
Loop
Ende = Timer
Gesamtdauer = Ende - Start
Call KuraÇek
End If
End If
End If
Exit Sub
End Sub

UYARI: Kırmızı kısım, her ismin bekleme süresini gösteriyor;bu bölgeden süreyi artırabilir veya azaltabilirsiniz. Mavi kısım, kura sırasında geçen isim sayısı; daha fazla ismi çevirmesini isterseniz, burayı da artırabilirsiniz.
Sonlara doğru seçim yavaşlayabilir; çünkü öğrencilerin tekrar seçilmemesini istemişsiniz.

Merhabalar. Benimde benzer bir sorum olacak. Dosyada belirttim. Yapılabilir mi.