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

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:
L

Levent Menteşoğlu

Administrator
Yönetici
Admin
Katılım
13 Ekim 2004
Mesajlar
16,057
Excel Vers. ve Dili
Excel 2010-32 bit-Türkçe
Excel 365 -32 bit-Türkçe
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.
 
L

lasmar

Misafir
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.
 
leumruk

leumruk

Uzman
Uzman
Katılım
15 Nisan 2007
Mesajlar
3,471
Excel Vers. ve Dili
Office 2010 & 2013 tr
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:
L

Levent Menteşoğlu

Administrator
Yönetici
Admin
Katılım
13 Ekim 2004
Mesajlar
16,057
Excel Vers. ve Dili
Excel 2010-32 bit-Türkçe
Excel 365 -32 bit-Türkçe
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

leumruk

leumruk

Uzman
Uzman
Katılım
15 Nisan 2007
Mesajlar
3,471
Excel Vers. ve Dili
Office 2010 & 2013 tr
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...
 
Hakan ERDOST

Hakan ERDOST

Destek Ekibi
Destek Ekibi
Katılım
12 Eylül 2004
Mesajlar
871
Excel Vers. ve Dili
Excel 2019 Türkçe (Ev)
Excel 2013 Türkçe (Okul)
Üstatlar bu kodda hafta sonalrına gelen günleri nasıl atlatabiliriz.O günlere nöbet gelmese.
 
Hakan ERDOST

Hakan ERDOST

Destek Ekibi
Destek Ekibi
Katılım
12 Eylül 2004
Mesajlar
871
Excel Vers. ve Dili
Excel 2019 Türkçe (Ev)
Excel 2013 Türkçe (Okul)
Teşekkürler.
 
L

lasmar

Misafir
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

leumruk

Uzman
Uzman
Katılım
15 Nisan 2007
Mesajlar
3,471
Excel Vers. ve Dili
Office 2010 & 2013 tr
G

Gorarr

Katılım
31 Ağustos 2010
Mesajlar
387
Excel Vers. ve Dili
Excel 2007-2010 Eng
Open Office Trk
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..
 
L

lasmar

Misafir
elleriniz dert görmesin

gerçekten güzel sonuç. çok teşekkür ederim.
 
leumruk

leumruk

Uzman
Uzman
Katılım
15 Nisan 2007
Mesajlar
3,471
Excel Vers. ve Dili
Office 2010 & 2013 tr
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.
 
G

Gorarr

Katılım
31 Ağustos 2010
Mesajlar
387
Excel Vers. ve Dili
Excel 2007-2010 Eng
Open Office Trk
Teşekkür ederim.. Heyecanla bekliyorum. Olmazsada canınız sağolsun.. iyigeceler..
 
leumruk

leumruk

Uzman
Uzman
Katılım
15 Nisan 2007
Mesajlar
3,471
Excel Vers. ve Dili
Office 2010 & 2013 tr
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:
G

Gorarr

Katılım
31 Ağustos 2010
Mesajlar
387
Excel Vers. ve Dili
Excel 2007-2010 Eng
Open Office Trk
Çook çok teşekkür ederim. Ellerinize sağlık. Muhteşem olmuş.. Hatta sanat eseri olmuş..
 
Hakan ERDOST

Hakan ERDOST

Destek Ekibi
Destek Ekibi
Katılım
12 Eylül 2004
Mesajlar
871
Excel Vers. ve Dili
Excel 2019 Türkçe (Ev)
Excel 2013 Türkçe (Okul)
Üstat şu hafta sonu kodunu nereye ialev edeceğiz.Hafta sonlarına nöbet gelmesin.
 
leumruk

leumruk

Uzman
Uzman
Katılım
15 Nisan 2007
Mesajlar
3,471
Excel Vers. ve Dili
Office 2010 & 2013 tr
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:
wezyr

wezyr

Altın Üye
Katılım
14 Nisan 2006
Mesajlar
110
Excel Vers. ve Dili
OFFİCE 2010-2019
Altın Üyelik Bitiş Tarihi
21-04-2029
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.
Üst