Kura Çekim Programı

[ALTINYAYLA]

Selamlar arkadaşlar ekte gönderdiğim örnek dosyada bir kura çekim programı yapmaya çalışıyorum. Gerekli açıklama dosyanın içerisinde . Yardımlarınızı rica eder selamlarımı sunarım...

 

[ÖmerBey]

Aleykum selam,
Aşağıdaki kodları deneyiniz.

Sub KOD()
son = Range("D65500").End(3).Row
If son - 5 < Range("C3") Then MsgBox "Listedeki öğretmen sayısı yetersiz.": Exit Sub
If Range("C2") > Range("C3") / 2 Then MsgBox "Komisyon sayısı öğretmen sayısına göre fazla.": Exit Sub
Range("E6:E65500").ClearContents
Do While say < Range("C2")
say = say + 1
1
    s1 = WorksheetFunction.RandBetween(6, son)
    If Cells(s1, "E") = "" Then Cells(s1, "E") = say & "B" Else GoTo 1
2
    s2 = WorksheetFunction.RandBetween(6, son)
    If Cells(s2, "E") = "" Then Cells(s2, "E") = say & "Ü" Else GoTo 2

Loop
For a = 1 To Range("C3") - 2 * Range("C2")
3
    s3 = WorksheetFunction.RandBetween(6, son)
    If Cells(s3, "E") = "" Then Cells(s3, "E") = "Y" & a Else GoTo 3
Next
End Sub

 

[ALTINYAYLA]

hocam kafam durdu bunu ilgili dosyaya ekleyemedim ekleyip paylaşabilirmisiniz. selamlarımla

 

[ÖmerBey]

Üstteki mesaja dosya eklendi.

 

[ALTINYAYLA]

Üstteki mesaja dosya eklendi.

Hocam emeğinize sağlık hakkınızı hela ediniz.

 

[Muhammet Okumuş]

Merhaba,
Sn Leumruk'un yöntemi ile sonuca ulaşılabilir.

Sub Kura()
Application.ScreenUpdating = False
Range("E6:E10000") = ""
For i = 1 To Range("C2")
son = Cells(Rows.Count, 5).End(3).Row + 1
Cells(son, 5) = "B" & i
Cells(son + 1, 5) = "Ü" & i
Next
a = Cells(Rows.Count, 5).End(3).Row
b = Cells(Rows.Count, 4).End(3).Row
For i = 1 To b - a
son = Cells(Rows.Count, 5).End(3).Row + 1
Cells(son, 5) = "Y" & i
Next
son = Cells(Rows.Count, 5).End(3).Row
dz = Range("E6:E" & son)
Randomize

For x = UBound(dz, 1) To 1 Step -1

sayi = Int((x * Rnd) + 1)

hcr = dz(sayi, 1)
dz(sayi, 1) = dz(x, 1)
dz(x, 1) = hcr
Next
Range("E6:E" & son) = dz
End Sub