• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

nöbet listesine eşit sayıda ama rastgele sırayla isim dağıtmak

  • Konbuyu başlatan Konbuyu başlatan lasmar
  • Başlangıç tarihi Başlangıç tarihi
L

lasmar

Misafir
Merhaba arkadaşlar,

6 kişilik ve bir aylık hazırlanacak nöbet listesine, verilen isimleri eşit sayıda ama rastgele sırayla dağıtacak bir Makro-VBA kodu lazım. Örnek dosya ektedir. Mesajı atmadan önce sitemizde çok aradım ama cevap bulamadım.
 

Ekli dosyalar

Son düzenleme:
B sütununda 41 isim var. Ekim ayına ait tabloda ise 186 alan. Herkese eşit nöbet nasıl yazılacaktır. Biraz daha detay bilgi verirmisiniz.
 
41 kişi (sabit olmamakla beraber), 22 kişi 5 nöbet, 19 kişi 4 nöbet tutarsa (22*5)+(19*4)=186 alana en adil şekilde dağılmış olur. (hangi güne geldiğinin önemi yoktur.)
ilginize teşekkür ederim.
 
Merhaba,
İlgili ayı d1 hücresinden seçin ve butona basın.
Tarih kodu: Bo kod Sayfa1'in kod bölümünde olacak. Seçilen tarihin hücrelere yerleşmesini sağlar. C sütunu dağıtım sayısını görmeniz için eklendi, dilerseniz silebilirsiniz.

NOT: Yeni eklenen dosyaya sorgu eklendi. Kodları çalıştırdığınızda haftasonunu dahil edip etmeyeceğiniz sorulur. Cevabınıza göre işlem gerçekleşir.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [d1,e1]) Is Nothing Then Exit Sub
If [d1] = "" Or [e1] = "" Then Exit Sub
[d3:d65536].ClearContents
Ay = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
Ay = WorksheetFunction.Match([d1], Ay, 0)
tarih = CDate("01." & Ay & "." & [e1])
Gün = DateSerial(Year(tarih), Month(tarih) + 1, 0)
For x = 3 To Format(Gün, "dd") + 2
    Cells(x, "d") = Format(CDate(x - 2 & "." & Ay & "." & [e1]), "dd.mm.yyyy")
Next
End Sub
Dağıtma kodu: İsimleri eşit oranda rastgele dağıtır.
Kod: 
Sub yerlestir()
Dim hcr As Variant, varTemp As Variant
Application.ScreenUpdating = False
Range("e3:j65536").ClearContents
Set Aralik = Range("b3:b" & [b65536].End(3).Row)
hcr = Aralik
Tpl = UBound(hcr, 1)
[COLOR="blue"]Sor = MsgBox("Haftasonuna denk gelen günler dahil edilsin mi?", vbYesNo)[/COLOR]
For Each y In Range("e3:j" & [d65536].End(3).Row)
[COLOR="Blue"]If Sor = vbNo And DatePart("w", CDate(Cells(y.Row, "d")), vbMonday) > 5 Then GoTo Son[/COLOR]
If Tpl = 0 Then Tpl = UBound(hcr, 1)
Tekrar:
sayi = Int(Rnd() * Tpl + 1)
Sy = WorksheetFunction.CountIf(Range(Cells(y.Row, 5), Cells(y.Row, 10)), hcr(sayi, 1))
If Sy > 0 Then GoTo Tekrar
Cells(y.Row, y.Column) = hcr(sayi, 1)
varTemp = hcr(Tpl, 1)
hcr(Tpl, 1) = hcr(sayi, 1)
hcr(sayi, 1) = varTemp
Tpl = Tpl - 1
[COLOR="blue"]Son:[/COLOR]
Next
End Sub
 

Ekli dosyalar

Son düzenleme:
Bende dosyayı tamamlamıştım ekliyorum. Sn Mustafa beyle benzer bir mantık kullanmışız.


Mustafa beye Not: Çalışmanız, aynı tarihte bir isme birden fazla nöbet yazabiliyor. Bunu düzeltirseniz güzel bir çalışma olacak.
 

Ekli dosyalar

Levent Menteşoğlu' Alıntı:
Bende dosyayı tamamlamıştım ekliyorum. Sn Mustafa beyle benzer bir mantık kullanmışız.

Mustafa beye Not: Çalışmanız, aynı tarihte bir isme birden fazla nöbet yazabiliyor. Bunu düzeltirseniz güzel bir çalışma olacak.
Genişletmek için tıkla ...
Levent Bey, uyarınız için teşekkür ederim. İlgili mesajdaki kod ve dosyayı güncelledim.
Saygılar...
 
Üstatlar bu kodda hafta sonalrına gelen günleri nasıl atlatabiliriz.O günlere nöbet gelmese.
 
Teşekkürler.
 
renklendirilmiş hafta sonu ve resmi tatiller

zaman ayırdığınız için teşekkür ederim. son olarak oluşturduğunuz takvimde hafta sonuna ve resmi tatillere denk gelen günler farklı renklerle belirtilebilir mi?
bu sorunumuda eklediğim belge üzerinde tarif edebilirseniz sevinirim.
 

Ekli dosyalar

Son düzenleme:
leumruk arkadaşım ellerinize sağlık tek kelime ile muhteşem olmuş. çok işime yarayacak.

Buarada bir ayrıntı eklenmesi mümkünmü nöbet tutacaklar için istediğimiz sayıda tutmasını sağlayabilirmisiniz. Teşekkürler..
 
elleriniz dert görmesin

gerçekten güzel sonuç. çok teşekkür ederim.
 
Gorarr' Alıntı:
leumruk arkadaşım ellerinize sağlık tek kelime ile muhteşem olmuş. çok işime yarayacak.

Buarada bir ayrıntı eklenmesi mümkünmü nöbet tutacaklar için istediğimiz sayıda tutmasını sağlayabilirmisiniz. Teşekkürler..
Genişletmek için tıkla ...
Bu istediğiniz yapılabilir gibi görünüyor; ancak kod yapısının değişmesi gerekiyor. Bir aksilik çıkmazsa yarın yapmaya çalışayım.
 
Teşekkür ederim.. Heyecanla bekliyorum. Olmazsada canınız sağolsun.. iyigeceler..
 
Gorarr' Alıntı:
leumruk arkadaşım ellerinize sağlık tek kelime ile muhteşem olmuş. çok işime yarayacak.

Buarada bir ayrıntı eklenmesi mümkünmü nöbet tutacaklar için istediğimiz sayıda tutmasını sağlayabilirmisiniz. Teşekkürler..
Genişletmek için tıkla ...
Merhaba,
Ekteki örnek dosyayı inceleyiniz. C sütununa her isim için el ile nöbet sayılarını girin. Girdiğiniz nöbet sayısı ayın gün sayısından fazla olmamalı.

NOT: Yeni eklenen bu dosya daha öncekinden farklı bir kod yapısına sahip. Haftasonunun dahil edilip edilmeyeceğine dair çıkan sorgu tarih makrosuna eklendi. D1'den ay seçimi yaptığınızda isteğinize göre haftasonu dahil edilerek veya edilmeyerek ilgili sütuna sıralanacaktır.

Kod: 
Sub yerlestir2()
Dim deg As Variant, varTemp As Variant
Range("e3:j65536").ClearContents
Gün = WorksheetFunction.CountA(Range("d3:d" & [d65536].End(3).Row))
Nobet = Val(WorksheetFunction.Sum(Range("c3:c" & [b65536].End(3).Row)))


If Gün * 6 < Nobet Then
MsgBox "Girdiğiniz nöbet sayıları dağıtılabilecek orandan fazla. Girebileceğiniz toplam nöbet sayısı: " & _
Gün * 6 & " olmalıdır.", vbCritical, "TÜM HAFTA"
Exit Sub
End If

If WorksheetFunction.Max(Range("c3:c" & [b65536].End(3).Row)) > Gün Then
MsgBox "Bir kişiye ayın gün sayısından fazla nöbet girişi yapamazsınız. Veri girişinizi kontrol ediniz.", vbCritical, "UYARI"
Exit Sub
End If

Set Aralik = Range("e3:j" & [d65536].End(3).Row)
deg = Aralik

Sat = 0
Say = 1
For x = 3 To [b65536].End(3).Row
If Cells(x, "c") > 0 Then
    For y = 1 To Cells(x, "c")
        Sat = Sat + 1
        deg(Sat, Say) = Cells(x, "b")
    If Sat = Gün Then Sat = 0: Say = Say + 1
    Next
End If
Next

yenile:
satir = 3
For i = 1 To 6
Tpl = UBound(deg)
Do
Tekrar:
If Son > 3000 Then Son = 0: Range("e3:j65536").ClearContents: GoTo yenile: Exit For
sayi = Int(Rnd() * Tpl + 1)
varTemp = deg(Tpl, i)
deg(Tpl, i) = deg(sayi, i)
sorgu = deg(sayi, i)
deg(sayi, i) = varTemp
If deg(sayi, i) <> "" Then
Sy = WorksheetFunction.CountIf(Range(Cells(satir, 5), Cells(satir, 10)), sorgu)
If Sy > 0 Then
For knt = 3 To Cells(65536, i + 4).End(3).Row
    Srg1 = WorksheetFunction.CountIf(Range(Cells(knt, 5), Cells(knt, 10)), sorgu)
    Srg2 = WorksheetFunction.CountIf(Range(Cells(satir, 5), Cells(satir, 10)), Cells(knt, i + 4))
    If Srg1 = 0 And Srg2 = 0 Then
    Cells(satir, i + 4) = Cells(knt, i + 4)
    Cells(knt, i + 4) = sorgu
    GoTo tmm
    End If
Next
Tpl = UBound(deg)
Range(Cells(3, i + 4), Cells(33, i + 4)).ClearContents
satir = 3
Son = Son + 1
GoTo Tekrar
End If
End If

Cells(satir, i + 4) = sorgu

tmm:

satir = satir + 1
Tpl = Tpl - 1
Loop While Tpl <> 0
satir = 3
Next
End Sub
 

Ekli dosyalar

Son düzenleme:
Çook çok teşekkür ederim. Ellerinize sağlık. Muhteşem olmuş.. Hatta sanat eseri olmuş..
 
Üstat şu hafta sonu kodunu nereye ialev edeceğiz.Hafta sonlarına nöbet gelmesin.
 
hexadesimal' Alıntı:
Üstat şu hafta sonu kodunu nereye ialev edeceğiz.Hafta sonlarına nöbet gelmesin.
Genişletmek için tıkla ...
İlgili mesajı güncelledim. Kod yapısı değiştiği için haftasonu seçeneğini tarih seçimi kodlarına ekledim. İlgili mesajda gerekli açıklamaları yaptım.

UYARI: 4 nolu mesajdaki dosyada kullanılan sistemle 16 nolu mmesajda kullanılan sistem birbirinden farklıdır.
4 nolu mesajdaki dosyada C sütununda sayı belirtilmiyor. Nöbet isimler arasında eşit olarak dağıtılıyor.
16 nolu mesajda eklenen kodda ise C sütununa sayı girişi yapılıyor ve bu sayılara göre nöbet dağılımı yapılıyor.
 
Son düzenleme:
bende bir istekete bulunabilirmiyim...
pansiyonda nöbet için
koşullar hafta içi günlerde 2 kişi cumartesi pazar 1 kişi nöbet tutacak
birkişiye haftada 2 nöbetten fazla verilmeyecek ve nöbetler aynı kişiye arka arkaya gelmeyecek
a kişisi pazartesi ve çarşamba
b kişisi salı ve perşembe sabit olmak üzere
mümkün olduğu kadar eşit bir şekilde dağıtılması
örnek dosya olarak 16. mesajdaki dosyayı kullanabiliriz
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst