kura çekiliş

[gezgin-49]

sayın üstadlarım kura yöntemi ile kişi seçmek istiyorum,
Sayfa1 de B sütununda 50 kişi varsa A sütununda birden 50'ye kadar karışık sayı atmasını istiyorum,

B sütununda 500 kişi varsa A sütununa karışık olarak 500'e kadar sayı atmasını istiyorum, buna ilişkin bir makro yapılabilir mi

 

[Korhan Ayhan]

İnceleyiniz..

excel kura programı

Merhaba Arkadaşlar bir sayfada isim listeleri ve yanlarında tc kimlik numaraları yer alacak diğer sayfada ise kura çek butonu olacak her isim sadece bir defa çekilebilmeli ve rastgele atama yapılmalı atama yaparken ad soyad ve tc lerini beraber alması lazım Bu programı personeli atama yapmak...

www.excel.web.tr

 

[gezgin-49]

sayın üstadım Allah razı olsun ama benim istediğim biraz daha farklı, önce kura çekilmesi istenilen kişi sayısını belirleyecek bir seçenek gelmesi lazım, bu seçeneğe kaç kişilik kura çekileceği yazıldıktan sonra sonra kura çek dediğim zaman bütün hepsini bir anda vermeli,
aslında forumda dolaşırken istediğime yakın bir çözüm var ancak, çekiliş yapılacak kişi sayısı arttıkça kodlar çok hantallaşıyor, bu kodlarda bir oynama yapılarak belki hızlandırılabilir.

Sub cekilis()
Dim Counter As Integer
Dim son As Long
son = Range("A" & Rows.Count).End(3).Row
On Error GoTo myErrorCheck
Application.EnableCancelKey = xlErrorHandler

ActiveWorkbook.Names.Add "Liste", RefersToR1C1:="=kura!R1C1:R" & son & "C1"
Range("Liste").Offset(0, 1).Select
Selection.ClearContents
[b1:b1000] = ""
Counter = 1
While Counter < Range("Liste").Rows.Count
For Each www In Worksheets(1).Range("Liste")
Randomize

Selection.Interior.ColorIndex = xlNone
Range(www.Address()).Select
Selection.Interior.ColorIndex = 24

If Int((10 * Range("Liste").Rows.Count + 1) * Rnd()) = Selection.Row Then
If Selection.Offset(0, 1).Value = "" Then
Selection.Offset(0, 1).Value = Counter
Counter = Counter + 1
End If
End If

Next
Wend

For Each www In Worksheets(1).Range("Liste")
If www.Offset(0, 1).Value = "" Then
www.Offset(0, 1).Value = Counter
End If
Next

myErrorCheck:
If Err = 18 Then
If MsgBox("kura durduruldu/Bozuldu, Devam etmek için HAYIR'a tıklayın", 4, " KENAN ÜMÜT (Yazı İşleri Müdürü)") = 7 Then
Resume Next
End If
End If

Selection.Interior.ColorIndex = xlNone

Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

End Sub

 

[veyselemre]

Sub test()
    Dim son&, i&, ii&, tmp
    son = Cells(Rows.Count, 2).End(3).Row
    ReDim sayilar(1 To son, 1 To 2)
    For i = 1 To son
        sayilar(i, 1) = i
        sayilar(i, 2) = Rnd
    Next i
    For i = 1 To son - 1
        For ii = i + 1 To son
            If sayilar(i, 2) > sayilar(ii, 2) Then
                tmp = sayilar(i, 1)
                sayilar(i, 1) = sayilar(ii, 1)
                sayilar(ii, 1) = tmp
                tmp = sayilar(i, 2)
                sayilar(i, 2) = sayilar(ii, 2)
                sayilar(ii, 2) = tmp
            End If
        Next ii
    Next i
    Range("A1").Resize(son, 1).Value = sayilar
End Sub

Sub test2()
    Dim son&, i&, ii&, kys, say&
    son = Cells(Rows.Count, 2).End(3).Row
    ReDim sayilar(1 To son, 1 To 1)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To son
            .Item(i) = i
        Next i
        Do While .Count > 0
            say = say + 1
            kys = .keys
            ii = WorksheetFunction.RandBetween(0, .Count - 1)
            sayilar(say, 1) = kys(ii)
            .Remove kys(ii)
        Loop
    End With
    Range("A1").Resize(son, 1).Value = sayilar
End Sub

Sub test3()
    Dim son&, i&, ii&, say&
    son = Cells(Rows.Count, 2).End(3).Row
    ReDim sayilar(1 To son, 1 To 1)
    With New Collection
        For i = 1 To son
            .Add i
        Next i
        Do While .Count > 0
            say = say + 1
            ii = WorksheetFunction.RandBetween(1, .Count)
            sayilar(say, 1) = .Item(ii)
            .Remove ii
        Loop
    End With
    Range("A1").Resize(son, 1).Value = sayilar
End Sub

 

[gezgin-49]

Sayın üstadım Veyselemre ve Korhan Ayhan Allah razı olsun çok teşekkür ederim, iyiki varsınız