- Katılım
- 25 Ocak 2008
- Mesajlar
- 142
- Excel Vers. ve Dili
- 2003
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub yerlestir()
Dim hcr As Variant, varTemp As Variant
Dim Aralik As Range
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
If WorksheetFunction.CountA(Range("d4:d34")) = 0 Then
MsgBox "Tarih seçimi yapmamışsınız."
Exit Sub: End If
If WorksheetFunction.CountIf(Range("e4:e" & [d65536].End(3).Row), "") = 0 Then
MsgBox "Listeyi temizlemeden bu makroyu kullanamazsınız."
Exit Sub: End If
s2.Range("d5:k" & s2.[c65536].End(3).Row).ClearContents
Set Aralik = Range("b2:b" & [b65536].End(3).Row)
hcr = Aralik
Tpl = UBound(hcr, 1)
Sor = MsgBox("Haftasonuna denk gelen günler dahil edilsin mi?", vbYesNo)
Randomize
For Each y In Range("e4:e" & [d65536].End(3).Row).SpecialCells(xlCellTypeBlanks)
If Sor = vbNo And DatePart("w", CDate(Cells(y.Row, "d")), vbMonday) > 5 Then GoTo Son
If Tpl = 0 Then Tpl = UBound(hcr, 1)
sayi = Int(Rnd() * Tpl + 1)
Cells(y.Row, y.Column) = hcr(sayi, 1)
Set Bul = s2.Range("c5:c" & s2.[c65536].End(3).Row).Find(hcr(sayi, 1))
If Not Bul Is Nothing Then
s2.Cells(Bul.Row, s2.Cells(Bul.Row, 11).End(1).Column + 1) = Day(Cells(y.Row, "d"))
End If
varTemp = hcr(Tpl, 1)
hcr(Tpl, 1) = hcr(sayi, 1)
hcr(sayi, 1) = varTemp
Tpl = Tpl - 1
Son:
Next
End Sub
Merhaba,hocam çok güzel olmu elinize sağlık
ancak güne göre değilde personele göre yapsak ----- atama yapılmayacak personeli kurs izin durumları oluyor sayfa 2 de açıklama var