Sıralı Kura Çekme Programı

[krcysf93]

Merhabalar sayın hocalarım.
Yüklediğim örnekte sütunlarda verilen isimler için butona tıklandığında o isme işaret koyup kura çekme programı için yardımınıza ihtiyacım var. Yardımcı olandan Allah razı olsun. Selametle kalın..

 

[Muhammet Okumuş]

Merhaba; deneyiniz.

Sub Kura()

son = Cells(Rows.Count, 3).End(3).Row
Range("D2:H" & son) = ""
For i = 2 To son
10
a = WorksheetFunction.RandBetween(4, 8)
If b = a Then GoTo 10
Cells(i, a) = "x"
b=a
Next

End Sub

 

[veyselemre]

Sub test()
    Dim i&, ii%, son, sut%, say, w%(4 To 8), farkliVar As Boolean, mx%
    son = Cells(Rows.Count, 3).End(3).Row
    Range("D2:H" & son).ClearContents
    For i = 2 To son
        farkliVar = Not (w(4) = w(5) = w(6) = w(7) = w(8))
bas:
        say = say + 1
        sut = WorksheetFunction.RandBetween(4, 8)
        If (Cells(i - 1, sut).Value = "X" Or (farkliVar And w(sut) = mx)) And say < 10 Then
            GoTo bas
        Else
            say = 0
            w(sut) = w(sut) + 1
            If w(sut) > mx Then mx = w(sut)
            Cells(i, sut).Value = "X"
        End If
    Next i
End Sub

 

[Necdet]

Merhaba,
Ben de bir şeyler yazmıştım.
Aşağıdaki kodları bir modüle kopyalayın ve butona bağlayın.
her basışta isteğiniz olacaktır.

Sub Deneme()

Dim sat As Integer
Dim kol As Integer

sat = Range("D:H").Find("*", , , , xlByRows, xlPrevious).Row + 1
Yinele:
kol = Application.WorksheetFunction.RandBetween(4, 8)
If Not Cells(sat - 1, kol) = "X" Then
    Cells(sat, kol) = "X"
Else
    GoTo Yinele
End If
Range("I" & sat + 1).Activate

End Sub

 

[Tevfik_Kursun]

Sayın Veysel Emre Hocam,
Bu dağıtımı, aynı kişiye, en az 3 ya da 4 günde bir gelecek şekilde nasıl yaparsınız ve düşeyi yataya nasıl çevirirsiniz?
Saygılarımla

 

[veyselemre]

Sayın Veysel Emre Hocam,
Bu dağıtımı, aynı kişiye, en az 3 ya da 4 günde bir gelecek şekilde nasıl yaparsınız ve düşeyi yataya nasıl çevirirsiniz?
Saygılarımla

Saygı bizden size olsun.

Sub testDusey()
'   Veysel Emre 12.01.2024
    Dim i&, ii%, son, sat%, say, w%(), farkliVar As Boolean, mx%, onc1, onc2, onc3
    son = Cells(Rows.Count, 5).End(3).Row
    ReDim w(4 To son)
    Range("F4:AJ" & son).ClearContents
    For i = 6 To 36
        farkliVar = False
        For ii = 4 To son - 1
            If w(ii) <> w(ii + 1) Then
                farkliVar = True
                Exit For
            End If
        Next ii
bas:
        say = say + 1
        sat = WorksheetFunction.RandBetween(4, son)
        If say > 19 Then Debug.Print i
        If (onc1 = sat Or onc2 = sat Or onc3 = sat Or (farkliVar And w(sat) = mx)) And say < 20 Then
            GoTo bas
        Else
            say = 0
            w(sat) = w(sat) + 1
            If w(sat) > mx Then mx = w(sat)
            Cells(sat, i).Value = "X"
            onc3 = onc2
            onc2 = onc1
            onc1 = sat
        End If
    Next i
End Sub

 

[Tevfik_Kursun]

Sayın Veysel Emre Hocam,
İlginize çok teşekkür ederim.
Saygılarımla

 

[krcysf93]

Hastaydım bakamadım hepinize ilginizden dolayı teşekkür ederim hocalarım Allah razı olsun