- Katılım
- 18 Nisan 2017
- Mesajlar
- 112
- Excel Vers. ve Dili
- 2016 c++
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub rastgele()
son = WorksheetFunction.Max(2, Cells(Rows.Count, "C").End(3).Row)
Range("D2:D" & son).ClearContents
For i = 2 To son
10:
say = WorksheetFunction.RandBetween(2, son)
If WorksheetFunction.CountIf(Range("D2:D" & son), Cells(say, "C")) = 0 Then
Cells(i, "D") = Cells(say, "C")
Else
GoTo 10
End If
Next
End Sub
Sub salonlar()
Set s1 = Sheets("GENEL LİSTE")
son = s1.Cells(Rows.Count, "A").End(3).Row
'son = 30
For salon = 1 To Sheets.Count
If WorksheetFunction.CountBlank(s1.Range("D2:D" & son)) = 0 Then
MsgBox "Boşta kalan öğrenci bulunmamaktadır!"
Exit Sub
End If
If Sheets(salon).Name <> s1.Name Then
For küme = 2 To 8 Step 3
For sıra = 14 To 22 Step 2
10:
öğrenci1 = WorksheetFunction.RandBetween(2, son)
If s1.Cells(öğrenci1, "D") <> "" Then
Sheets(salon).Cells(sıra, küme) = s1.Cells(öğrenci1, "C") & _
Chr(10) & s1.Cells(öğrenci1, "B") & Chr(10) & s1.Cells(öğrenci1, "A")
20:
öğrenci2 = WorksheetFunction.RandBetween(2, son)
If s1.Cells(öğrenci2, "D") <> "" And s1.Cells(öğrenci2, "A") <> s1.Cells(öğrenci1, "A") Then
Sheets(salon).Cells(sıra, küme + 1) = s1.Cells(öğrenci2, "C") & _
Chr(10) & s1.Cells(öğrenci2, "B") & Chr(10) & s1.Cells(öğrenci2, "A")
Else
GoTo 20
End If
Else
GoTo 10
End If
Next
Next
End If
Next
If WorksheetFunction.CountBlank(s1.Range("D2:D" & son)) > 0 Then
MsgBox "Öğrenci dağıtımı tamamlandı ancak boşta kalan öğrenci(ler) var!"
Else
MsgBox "Öğrenci dağıtımı tamamlandı"
End If
End Sub
sağlık olsun hocam. üstadlardan fikri olan çıkar belkiDaha önce de belirttiğim gibi bende de aynısı oluyor maalesef. Neden bilmiyorum.![]()