Liste içinde rasgele numara seçimi yapmak

[erhan1232]

Liste içinde rasgele numara seçimi yapmak istiyorum ekte bir örnek bulunmaktadır.. Listeki numaralardan rasgele 20 numara seçip sheet 2ye kopyalanmasını istiyorum.. yardımcı olan arkadaşlara şimdiden teşekkürler..

 

[Orion1]

Dosyanız ektedir.

Sub rastgele()
Dim col As Collection, i As Long, sat As Long, indis As Long
Set col = New Collection
Sheets("Sheet2").Range("A2:A65536").ClearContents
Sheets("Sheet1").Select
sat = 2
For i = 1 To Cells(65536, "A").End(xlUp).Row
    col.Add Cells(i, "A").Value
Next
Randomize Timer
For i = 1 To 20
    indis = Int(Rnd() * col.Count) + 1
    Sheets("Sheet2").Cells(sat, "A").Value = col.Item(indis)
    sat = sat + 1
    col.Remove (indis)
Next i
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[erhan1232]

Dosyanız ektedir.

Sub rastgele()
Dim col As Collection, i As Long, sat As Long, indis As Long
Set col = New Collection
Sheets("Sheet2").Range("A2:A65536").ClearContents
Sheets("Sheet1").Select
sat = 2
For i = 1 To Cells(65536, "A").End(xlUp).Row
    col.Add Cells(i, "A").Value
Next
Randomize Timer
For i = 1 To 20
    indis = Int(Rnd() * col.Count) + 1
    Sheets("Sheet2").Cells(sat, "A").Value = col.Item(indis)
    sat = sat + 1
    col.Remove (indis)
Next i
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "E V R E N"
End Sub

Teşekkürler seçilen rasgele sayıları 20den 50ye çıkarmak istersem ayarlamayı ben nasıl yapabilirim?

 

[Orion1]

Teşekkürler seçilen rasgele sayıları 20den 50ye çıkarmak istersem ayarlamayı ben nasıl yapabilirim?

Aşağıdaki kırmızı satırı güncelleyin.
Sub rastgele()
Dim col As Collection, i As Long, sat As Long, indis As Long
Set col = New Collection
Sheets("Sheet2").Range("A2:A65536").ClearContents
Sheets("Sheet1").Select
sat = 2
For i = 1 To Cells(65536, "A").End(xlUp).Row
col.Add Cells(i, "A").Value
Next
Randomize Timer
For i = 1 To 50
indis = Int(Rnd() * col.Count) + 1
Sheets("Sheet2").Cells(sat, "A").Value = col.Item(indis)
sat = sat + 1
col.Remove (indis)
Next i
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[erhan1232]

Teşekkürler fakat aklıma farklı birşey geldi yapabilirmiyiz acaba?
İstiyorumki bir önceki gibi ilk sheetde ayni şekilde çekilişe katılan numaralar olsun,
2. sheetde ise tüm database, cep telefonları ve isimler olsun,
3. sheetde 1. sheetden rasgele seçilen 20 kişi ve 2. sheetden bu rasgele seçilen 20 kişinin telefonları ve isimleri

Bu şekilde yapabilirsek çok sevinirim şimdiden teşekkürler..

Ekte örnek yükledim teşekkürler..

 

[abkbek]

Sayın Evren Gizlen,
yukarıdaki örneğe ikinci bir sütun ekleyip herbir satıra karşılık (yani sayıya) 1'den 10'a kadar değer atasak ve bu değere göre sayfadaki tüm sayıların karşılarında yazılı olan sayı kadar tekrar edecek şekilde maksimum 20'şerli gruplar halinde sayfalara rastgele dağılması sağlanabilir mi acaba?
ekteki örnek üzerinde yapabilirseniz çok memnun olurum. (sayfanın birinci sütununda yazan sayıları ikinci sütundaki değer kadar tekrar ettireceğiz) maksimum 20'şerli sayfalara dağıtılırken örneğin ikinci sütununda 1 yazılı olan rakamlar sadece bir sayfada, 2 yazanlar iki sayfada, 3 yazanlar üç sayfada ...... şeklinde olmalı

 

[Orion1]

Dosyanız ektedir.

Sub rastgele()
Dim z As Integer, i As Long, sat As Long, indis As Long
Dim k As Range, col As Collection
Set col = New Collection
Sheets("Sayfa1").Select
For i = 1 To 20
    Sheets(i).Range("E2:F65536").ClearContents
Next
For i = 1 To Cells(65536, "A").End(xlUp).Row
    col.Add Cells(i, "A").Value
Next
Randomize Timer
For i = 1 To 20
    indis = Int(Rnd() * col.Count) + 1
    Set k = Sheets("Sayfa1").Range("A:A").Find(col.Item(indis), , xlValues, xlWhole)
    For z = 1 To k.Offset(0, 1).Value
        sat = Sheets(z).Cells(65536, "E").End(xlUp).Row + 1
        Sheets(z).Cells(sat, "E").Value = col.Item(indis)
        Sheets(z).Cells(sat, "F").Value = "'" & z & "/" & k.Offset(0, 1).Value
    Next
   col.Remove (indis)
Next i
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[erhan1232]

Benim dosyam varmı acaba?

 

[Orion1]

Benim dosyam varmı acaba?

Görememişim.
Dosyanız ekte.

Sub rastgele2()
Dim col As Collection, i As Long, sat As Long, indis As Long
Dim s1 As Worksheet, s2 As Worksheet, k As Range
Set s1 = Sheets("Çekilişe Katılanlar")
Set s2 = Sheets("Database")
Set col = New Collection
Sheets("Kazanan kişiler ve cep telefonu").Select
Range("A2:C65536").ClearContents
sat = 2
For i = 1 To s1.Cells(65536, "A").End(xlUp).Row
    col.Add s1.Cells(i, "A").Value
Next
Randomize Timer
For i = 1 To 20
    indis = Int(Rnd() * col.Count) + 1
    Cells(sat, "A").Value = col.Item(indis)
    Set k = s2.Range("A2:A65536").Find(col.Item(indis), , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(sat, "B").Value = k.Offset(0, 1).Value
        Cells(sat, "C").Value = k.Offset(0, 2).Value
    End If
    sat = sat + 1
    col.Remove (indis)
Next i
Range("A2:C65536").Sort key1:=Range("C2"), key2:=Range("B2"), key3:=Range("A2")
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[erhan1232]

Çok teşekkürler..

 

[Orion1]

Çok teşekkürler..

Rica ederim.

 

[abkbek]

Sayın Evren Gizlen,
öncelikle soruma verdiğiniz cevap için çok teşekkür ederim. acaba bu rastgele dağıtımı kayıtların tümünü içerecek tarzda yapabilir miyiz, yani herbir kayıt kendi ikinci sütunundaki değer kadar tekrar edecek ve listeler azami 20'şerli olacak, öncelikle 20'şerli listeler tamamlanacak ondan sonrada 20'şerli oluşturulamayan (yeterli kayıt kalmadığı durumları kastediyorum) listeler ise listede aynı kayıt tekrar etmemek koşuluyla maksimum sayıda olacak. Yani değeri 2 olan kayıt iki listede 3 olan üç listede, 4 olan dört listede geçince doğal olarak geriye 20'yi tamamlayacak yeter sayıda kayıt kalmayacak ancak kalanlara ait listeler maksimum kayıt sayısıyla (herbir kaydın listede bir defa geçmek şartıyla) oluşturulacak. umarım mantığı anlatabilmişimdir. ilginizi bekliyorum.

 

[abkbek]

Sayın Evren Gizlen,
Vakit bulduğunuzda yukarıdaki sorumla ilgilenebilirseniz çok memnun olurum.

 

[abkbek]

Sayın Evren Gizlen,
Eğer cevap verebilirseniz minnettar olurum.

 

[glsh_841]

Arkadaşlar ekli dosyada bir sınav programı hazırladım. Excel otomatik personel seçiyor.personel görev aldığında yan taraftaki kutucuklarda x işaretinin olması ve bir kere görev verilen personele bir daha görev verilmemesi gerekiyor.personeller salon başkanı ve gözcü olarak seçilecek ve 2. Sayfaya atılacak.yardımcı olursanız sevinirim.

 

[honestman]

Hocam,

Toplamda 50 rastgele kura numarası seçiyoruz bu tamam.

Ama benim istediğim bu 50 numarayı adaletli olarak seçmesi. Yani databasedeki her isimden en az bir tane seçmeli ve mümkün olduğu kadar eşit sayıda seçmeli. Mesela database de toplam 25 kişi varsa random seçerken her isimden 2 adet seçmesi. Teşekkürler.

Sub rastgele()
Dim col As Collection, i As Long, sat As Long, indis As Long
Set col = New Collection
Sheets("Sheet2").Range("A2:A65536").ClearContents
Sheets("Sheet1").Select
sat = 2
For i = 1 To Cells(65536, "A").End(xlUp).Row
col.Add Cells(i, "A").Value
Next
Randomize Timer
For i = 1 To 50
indis = Int(Rnd() * col.Count) + 1
Sheets("Sheet2").Cells(sat, "A").Value = col.Item(indis)
sat = sat + 1
col.Remove (indis)
Next i
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[Orion1]

Hocam,

Toplamda 50 rastgele kura numarası seçiyoruz bu tamam.

Ama benim istediğim bu 50 numarayı adaletli olarak seçmesi. Yani databasedeki her isimden en az bir tane seçmeli ve mümkün olduğu kadar eşit sayıda seçmeli. Mesela database de toplam 25 kişi varsa random seçerken her isimden 2 adet seçmesi. Teşekkürler.

Sub rastgele()
Dim col As Collection, i As Long, sat As Long, indis As Long
Set col = New Collection
Sheets("Sheet2").Range("A2:A65536").ClearContents
Sheets("Sheet1").Select
sat = 2
For i = 1 To Cells(65536, "A").End(xlUp).Row
col.Add Cells(i, "A").Value
Next
Randomize Timer
For i = 1 To 50
indis = Int(Rnd() * col.Count) + 1
Sheets("Sheet2").Cells(sat, "A").Value = col.Item(indis)
sat = sat + 1
col.Remove (indis)
Next i
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "E V R E N"
End Sub

A sütununa her isimden 2 tane olacak şekilde 50 tane isim yazarsanız olur.

 

[honestman]

Malesef aynı isimden çok yazmak zorundayım. Çünkü bir kişi birden fazla numara almış oluyor.

 

[Orion1]

Malesef aynı isimden çok yazmak zorundayım. Çünkü bir kişi birden fazla numara almış oluyor.

Ben sorunuzu tam olarak anlamış değilim.

 

[honestman]

Hocam diyelim ki toplam 7 kişiye 150 bilet satıldı ve bu 7 kişiden her biri çok sayıda bilet satınaldı. ahmet 10 mehmet 2 ali 1 adet aldı mesela.

Diyelim ki 50 numara çekeceğim.

Çekeceğim kurada her isimden en az 1 kişi olmalı ve kişinin aldığı bilet sayısına göre oranlayarak random seçmeli. Ama alinin 1 bileti olmasına rağmen her kurada adı çıkmalı.