Rasgele her defasında değişen görev dağılımı

[burhan4]

Merhabalar Öncelikle istenen görev miktarları yazan yeden istenildiği kadar görevliyi diğer sekmedeki isimleri rasgele olacak şekilde atayıp diğer sayfaya yazdırsın bunu yapabilen olursa çok makbule geçer..

 

[dEdE]

Merhaba,
Forumumuza hoşgeldiniz.
Dosyanız ilişiktedir.

Sub RastgeleAta()
Set s1 = Sheets("İSTENEN MİKTAR")
Set s2 = Sheets("LİSTE")
Set s3 = Sheets("DAĞITIM SONUÇLARI")
MaxSayı = s2.Range("B" & Rows.Count).End(3).Row - 3

If WorksheetFunction.Sum(Range("C2:C" & MaxSayı)) > MaxSayı Then
    MsgBox "İstediğiniz miktar Kayıtlı Personel sayısından fazla.", vbCritical, "D İ K K A T !!!"
    Exit Sub
End If

For i = 2 To s1.Range("C" & Rows.Count).End(3).Row
    For j = 1 To s1.Cells(i, 3).Value
        Randomize
10      Sayı = Int((MaxSayı * Rnd) + 1)
        If WorksheetFunction.CountIf(s2.Range("C:C"), Sayı) > 0 Then GoTo 10
        s2.Cells(Sayı + 3, 3).Value = Sayı
        ss = s3.Range("B" & Rows.Count).End(3).Row + 1
        s3.Cells(ss, 2).Value = s2.Cells(Sayı + 3, 2).Value
        s3.Cells(ss, 3).Value = s1.Cells(i, 2).Value
    Next j
Next i

s2.Range("C:C").ClearContents
MsgBox "Rastgele Atama Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[burhan4]

tşk ettim eyvallah çok iyi

 

[yakamoz01]

çok güzelmiş @dede
hocam benim sorunuma da bakabilir misin?

http://www.excel.web.tr/f14/verileri-rastgele-syralamak-t130209.html