Kura sistemiyle dağıtım yardımı

[excelmaster]

Selamun aleyküm.

Ekteki dosyada kura sistemiyle departmandaki kişileri farklı bölümlere dağıtmak istedim. Dosyamda bazı eksiklikler mevcuttur. Gerekli açıklamalar dosya içerisindedir.

Yardımınızı rica ederim.

 

[Muhammet Okumuş]

Merhaba,

Sub Listele()
Range("E41000") = ""
süt = 2
son = Cells(Rows.Count, "A").End(3).Row
For i = 4 To son

For j = 1 To Cells(i, 2)
20
süt = süt + 3
If süt = 17 Then süt = 2
10
a = WorksheetFunction.RandBetween(1, Cells(i, 2))
kişi = Sheets(Cells(i, 1).Text).Cells(a, 2)
If WorksheetFunction.CountIf(Range("E"), kişi) > 0 Then GoTo 10
sat = Cells(1000, süt).End(3).Row + 1
If sat - Cells(2, süt) > 3 Then GoTo 20
Range(Cells(sat, süt), Cells(sat, süt + 1)) = Sheets(Cells(i, 1).Text).Range(Sheets(Cells(i, 1).Text).Cells(a, 1), Sheets(Cells(i, 1).Text).Cells(a, 2)).Value
Cells(sat, süt + 2) = Cells(i, 1).Value


Next
Next

End Sub

Kodu deneyiniz.

 

[excelmaster]

Veri sayısı artınca rastgele seçimden dolayı hata vermeden kısır döngüye giriyor.

 

[Muhammet Okumuş]

Merhaba,
Bir de bu kodu deneyiniz.

Sub Listele()
Range("E41000") = ""
süt = 2
son = Cells(Rows.Count, "A").End(3).Row
For i = 4 To son
alt = Sheets(Cells(i, 1).Text).Cells(Rows.Count, "A").End(3).Row
Sheets(Cells(i, 1).Text).Range("C1:C" & alt) = "=RAND()"
Sheets(Cells(i, 1).Text).Range("D1" & alt) = "=ROW(A1)"
Sheets(Cells(i, 1).Text).Range("C1" & alt) = Sheets(Cells(i, 1).Text).Range("C1" & alt).Value
Sheets(Cells(i, 1).Text).Range("A1" & alt).Sort Sheets(Cells(i, 1).Text).Range("C1")
For j = 1 To Cells(i, 2)
10
süt = süt + 3

If süt = 17 Then süt = 2
sat = Cells(1000, süt).End(3).Row + 1
If sat - Cells(2, süt) > 3 Then GoTo 10

Range(Cells(sat, süt), Cells(sat, süt + 1)) = Sheets(Cells(i, 1).Text).Range(Sheets(Cells(i, 1).Text).Cells(j, 1), Sheets(Cells(i, 1).Text).Cells(j, 2)).Value
Cells(sat, süt + 2) = Cells(i, 1).Value


Next
Sheets(Cells(i, 1).Text).Range("A1" & alt).Sort Sheets(Cells(i, 1).Text).Range("D1")
Sheets(Cells(i, 1).Text).Range("C") = ""
Next

End Sub

 

[excelmaster]

Allah razı olsun. Verdiğiniz kodlar işimi gördü.