Rastgele Dağıtma

[Ayhan Ercan]

Merhaba arkadaşlar.
uzun zamandır excel vba dan uzak kaldım. birazcık hatırlamak adına siz değerli üye ve uzmanlardan yardım talep ediyorum.

Sayfa1 de 400 isim var. (a,b,c,d,e,f,g,h sütunlarında 50 şer isim)
bu 400 ismi 16 adet sayfaya rastgele olarak 25 li gruplar oluşturacak bir koda ihtiyacım var.


not: 400 kişilik bir öğrenci listem var. 25 kişilik 16 tane sınıfa bu 400 öğrenciyi kura ile dağıtacam. kura ile olduğu için 400 kişiyi rastgele dağıtması gerekmekte.

 

[Emir Hüseyin Çoban]

. . .

Şu kodlar ile karışık sırada numara sırası oluşturabilirsiniz.

Daha sonra bu numaraları isimlerin yanına kopyalayıp.
Listeyi sıraladığınızda karışık isim listesi elde edebilirsiniz.

Sub benzersiz_rastgele()
son = 400

Dim arr() As Long
Min = "1" 'minimum değer
Max = son 'maksimum değer
ReDim arr(Max - Min)
say = 0
For i = Min To Max
arr(say) = i
say = say + 1
Next

For j = 0 To UBound(arr)
x = Int(((Max - Min) * Rnd))
temp = arr(x)
arr(x) = arr(j)
arr(j) = temp
Next j
For i = 0 To UBound(arr)
Cells(i + 1, "b") = arr(i)
Next
End Sub

. . .

 

[Ömer BARAN]

Merhaba.

Dağıtılacak ad soyadların;
-- ANA adlı sayfada yer aldığı,
-- birinci satırın başlık satırı olduğu ve dolayısıyla dağıtılacak verilerin A2:H51 aralığında olduğu
varsayılarak aşağıdaki kod'un işinizi görmesi gerekir.
NOT: Veriler açılan yeni sayfalara yazılıp, ANA adlı sayfadan silinmektedir.
.

[FONT="Arial Narrow"][B]Sub SAYFA_AÇ_DAĞIT()[/B]
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For syf = 1 To 16
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = syf
    ActiveSheet.[A1] = "ADI SOYADI"
        For kişi = 2 To 26
10:          sat = WorksheetFunction.RandBetween(2, 51): sut = WorksheetFunction.RandBetween(1, 8)
                If Sheets("[B][COLOR="blue"]ANA[/COLOR][/B]").Cells(sat, sut) = "" Then GoTo 10
                ActiveSheet.Cells(kişi, 1) = Sheets("[B][COLOR="Blue"]ANA[/COLOR][/B]").Cells(sat, sut): Sheets("[B][COLOR="blue"]ANA[/COLOR][/B]").Cells(sat, sut) = ""
        Next
Next
Sheets("[B][COLOR="blue"]ANA[/COLOR][/B]").Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "16 adet yeni sayfa oluşturulmuş," & vbLf & _
        "bu sayfadaki isimler ilgili sayfalara rastgele aktarılmıştır.", vbInformation, "İŞLEM TAMAM"
[B]End Sub[/B][/FONT]

 

[Ayhan Ercan]

Sayın Emir Hüseyin Çoban,
Sayın Ömer Baran,

İlgi, alaka ve desteğiniz için teşekkür ederim.

 

[Ömer BARAN]

İyi günler dilerim.

 

[Ayhan Ercan]

Sayın Ömer Baran,
Kodlarınızı denemek için kullandım. makroyu f8 ile adım adım çalıştırdığımda sorun olmuyor ancak makroyu f5 ile çalıştırdığım zaman "yanıt vermiyor"a atarak programı kilitliyor...

 

[ogameci]

Hocam random.org içinde randomize sıralatın.

 

[Ömer BARAN]

Sayın Ömer Baran,
Kodlarınızı denemek için kullandım. makroyu f8 ile adım adım çalıştırdığımda sorun olmuyor ancak makroyu f5 ile çalıştırdığım zaman "yanıt vermiyor"a atarak programı kilitliyor...

Tekrar merhaba.

Ekli belgeyi deneyiniz.

Belgeye buradan da ulaşabilirsiniz. Değişiklik : 03.08.2016 21:30
.

 

[Ayhan Ercan]

Teşekkür ederim sayın Ömer BARAN,
yolladığınız çalışma işime yaramadı desem yalan olur çok sağolun.

son olarak eğer zamanınız varsa 400 isim ve 16 sınıf sayılarını serbest bırakabilecek bir kod yazabilirmisiniz.
Yani 400 ismi 16 sınıfa 25'şerlik bir dizilim değilde, rakamların bilinmeyen olduğunu varsayalım.
mesela 400 isime uyarladığımız bu sistem 412 ye yüksedi veya 342 ye düştü. sınıflarda 16 değilde öğrenci listesine göre ortalama 25-30 öğrenci arası olduğunu düşünelim.
Zamanınız olur da yardımcı olabilirseniz cok sevinirim. yoksa yine de bu emeğiniz için yeniden çok teşekkürler...

 

[Ömer BARAN]

Tekrar merhaba.

Önceki cevabımın ekinde yer alan belgeyi yeniledim, sayfayı yenileyin ve tekrar indirerek deneyiniz.
Eklenenler;
-- Toplam kişi sayısı serbest, eşit satırlı olmasa da sütunlarda yer alan isimler dağıtılabilir,
-- Bir sınıftaki hedef kişi sayısı da serbest, kod çalıştığında karşınıza gelecek INPUTBOX'a bir sınıftaki hedef kişi sayısını yazmanız yeterli.
-- İşlem süresi 1 saniyenin altına indi.
.

 

[Ayhan Ercan]

Çok teşekkür ederim.

 

[cakir8432]

makro kaydet aktif değil

2007 excel kullanıyorum ancak makro güvenliğini de ayarlamama rağmen makro kaydet aktif değil bu işlerden de pek anlamam ama makro kaydetmek istiyorum tam olarak nasıl yapabilirim yardmcı olur musunuz

 

[yyyyyy111]

merhabalar. Ekte bulunan dosyada sayfa1 de bir isim listesi düşünelim bu isim listesi a-b-c-d-e sutunları aynı isimle ilgili bilgiler bulunmakta. isim listesindeki sayıya göre sabit sayıları bulunan salonlara rastgele dağıtmak istiyorum. bütün sütunlar aynen aktarılacak. burada salon sayılarına göre seçimi kendim yapmak istiyorum. örneğin listede 52 kişi var ben A salonu 30 F salonu 22 bu iki salonu seçtiğimde yeni sayfalarda A salonu sayfasına rastgele 30 kişi F salonuna rastgele 22 kişi atamasını istiyorum. veya 49 kişi var toplamı en yakın olanı kendim seçmek istiyorum. yardımcı olursanız sevinirim

 

[baydeniro]

. . .

Şu kodlar ile karışık sırada numara sırası oluşturabilirsiniz.

Daha sonra bu numaraları isimlerin yanına kopyalayıp.
Listeyi sıraladığınızda karışık isim listesi elde edebilirsiniz.

Sub benzersiz_rastgele()
son = 400

Dim arr() As Long
Min = "1" 'minimum değer
Max = son 'maksimum değer
ReDim arr(Max - Min)
say = 0
For i = Min To Max
arr(say) = i
say = say + 1
Next

For j = 0 To UBound(arr)
x = Int(((Max - Min) * Rnd))
temp = arr(x)
arr(x) = arr(j)
arr(j) = temp
Next j
For i = 0 To UBound(arr)
Cells(i + 1, "b") = arr(i)
Next
End Sub

. . .

Kod için teşekkürler üstad