kura çekme? excel hak.

[emsuak]

Merhaba Arkadaşlar;
ben bir kura çekme programı hazırlamak istiyorum excel de fakat nasıl başlıcaagımı nasıl yapacağım konusunda yardımlarınıza ihtiyacım var.
tam olarak yapmak istedigim;
60 kişilik bir liste butona bastıgımda listeden rasgele birisini seçmesi
ve kazandınız vs yazması
yardımlarınızı bekliyorum arkadaşlar

 

[hsayar]

Merhaba Arkadaşlar;
ben bir kura çekme programı hazırlamak istiyorum excel de fakat nasıl başlıcaagımı nasıl yapacağım konusunda yardımlarınıza ihtiyacım var.
tam olarak yapmak istedigim;
60 kişilik bir liste butona bastıgımda listeden rasgele birisini seçmesi
ve kazandınız vs yazması
yardımlarınızı bekliyorum arkadaşlar

öncelikle aşağıdaki foınksiyonu modulünüze kopyalayınız;

Function UniqueRandomNumbers(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long) As Variant
'Function UniqueRandomNumbers(NumCount As Long, LLimit As Long, ULimit As Long) As Variant
'Benzersiz Rastgele Sayılar Üretir.
' creates an array with NumCount unique long random numbers in the range LLimit - ULimit (including)
'Kullanımı Aşağıdaki gibidir
'Bir değişkene = (
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
UniqueRandomNumbers = False
 
If KacAdetSayi < 1 Then Exit Function
If EnKucukSayi > EnBuyukSayi Then Exit Function
If KacAdetSayi > (EnBuyukSayi - EnKucukSayi + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (EnBuyukSayi - EnKucukSayi) + EnKucukSayi)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = KacAdetSayi
 
ReDim varTemp(1 To KacAdetSayi)
For i = 1 To KacAdetSayi
varTemp(i) = RandColl(i)
Next i
'**************ripek********************
For i = 1 To KacAdetSayi - 1
    For j = i + 1 To KacAdetSayi
        If varTemp(i) > varTemp(j) Then
            k = varTemp(i)
            varTemp(i) = varTemp(j)
            varTemp(j) = k
        End If
    Next j
Next i
'**************ripek********************
Set RandColl = Nothing
UniqueRandomNumbers = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.tr***********
End Function

İsim listesinin a2:a61 aralığında oludğu varsayılmıştır.

Sadece 1 talihli için

Sub kura()
Sansli = UniqueRandomNumbers(1, 1, 60)
MsgBox "Asil: " & Range("[COLOR=red]a[/COLOR]" & Sansli(1))
End Sub

Asil ve yedek üye belirler.

Sub kura()
Sansli = UniqueRandomNumbers(2, 1, 60)
MsgBox "Asil: " & Range("a" & Sansli(1))
MsgBox "yedek: " & Range("a" & Sansli(2)) 'Sansli(2)
End Sub

 

[hsayar]

çalışma sayfasına koyacağınız butonunu kodlarına

private Sub CommandButton1_Click()
Call kura
End Sub

ve modüldeki yordamıda aşağıdaki gibi değiştirseniz

Sub kura()
Range("A2:B61").Interior.ColorIndex = xlNone
Range("b2:B61").Value = ""
Sansli = UniqueRandomNumbers(2, 1, 60)
MsgBox "Asil: " & Range("a" & Sansli(1))
MsgBox "yedek: " & Range("a" & Sansli(2)) 'Sansli(2)
Range("b" & Sansli(1)).Value = "ASİL TALİHLİ"
Range("A" & Sansli(1) & ":B" & Sansli(1)).Interior.Color = vbGreen
Range("b" & Sansli(2)).Value = "YEDEK TALİHLİ"
Range("A" & Sansli(2) & ":B" & Sansli(2)).Interior.Color = vbYellow
End Sub

sayfa üzerinde değişklikleri gözleyebilirsiniz...
arka sokaklar başladı
sizlere kolay gelsin...

 

[emsuak]

Arkadaşım ALLAH Senden razı olsun Vallaha büyüksün

sen Baya ayrıntıya girmişsin ama süper olmuş

ellerin dert görmesin.

 

[vuralkurt55]

resimli anlatım yaparmısınız? anlamıyorum. lütfennn..