Farklı Müsaitlik Günlerine Göre Nöbet Çizelgesi

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
H

haliliyas

Katılım
2 Temmuz 2014
Mesajlar
163
Excel Vers. ve Dili
2021 Türkçe, 64bit
H

haliliyas

Katılım
2 Temmuz 2014
Mesajlar
163
Excel Vers. ve Dili
2021 Türkçe, 64bit
Son olarak aşağıdaki kod da denenebilir daha sade ve dağılım daha dengeli gibi geldi. tabi yine Sayfa1.Range("MusaitPersonel") tanimlanmis olmalı.
Iyi çalışmalar.
Kod: 
Sub ListeYap_Rs_hy()  'Sorunsuz çalışıyor _hy
'_________________________________________________________________________
If Sayfa1.[r2] = "" Or Sayfa1.[s2] = "" Then MsgBox "ay yada yıl girilmemiş": Exit Sub
Sayfa1.[a2:B33].ClearContents

Dim xP, i, xYil, xAyAd, Ay, xAySay, Gun
   xYil = Sayfa1.Range("Yıl")
  xAyAd = Application.Proper(Sayfa1.Range("Ay"))
     Ay = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
xAySay = Application.Match(xAyAd, Ay, 0)
If Not IsNumeric(xAySay) Then MsgBox "ay adı hatalı girilmiş": Exit Sub
    Gun = Array("CUMARTES*", "PAZAR", "PAZARTES*", "SAL*", "ÇARŞAMBA", "PERŞEMBE", "CUMA")
    If xAySay Mod 2 = 0 Then xPerSira = "ASC" Else xPerSira = "DESC"
'__________________________________________________________________________
dzUygun = Sayfa1.Range("MusaitPersonel")
    Set UyGun_Rs = CreateObject("ADODB.Recordset")
    With UyGun_Rs
        .Fields.Append "Kisi", 200, 100
        .Fields.Append "UyGun", 200, 100
        .Fields.Append "NobetSay", 3
        .Fields.Append "UyGunSay", 3
        .Open      
        For x = LBound(dzUygun) To UBound(dzUygun)
        xVarMi = Application.Match(dzUygun(x, 2), Array("TÜm HAfTa", ""), 0)
        If IsNumeric(xVarMi) Then dzUygun(x, 2) = "PAZARTESİ, SALI, ÇARŞAMBA, PERŞEMBE, CUMA"
            xGunSay = UBound(Split("," & dzUygun(x, 2), ","))
              .AddNew Array(0, 1, 2, 3), Array(dzUygun(x, 1), dzUygun(x, 2), 0, xGunSay)
        Next x
            .Sort = "NobetSay, UyGunSay, Kisi " & xPerSira
     End With

Dim xAySon As Byte:     xAySon = Day(DateSerial(xYil, xAySay + 1, 0))
Dim dzTarih() As Variant: ReDim dzTarih(1 To xAySon, 1 To 2)
        For i = 1 To xAySon
            dzTarih(i, 1) = DateSerial(xYil, xAySay, i)
                     xMod = dzTarih(i, 1) Mod 7
                If xMod > 1 Then
                   xGun = Gun(xMod) '
                   xFiltre = Replace("UyGun like '*" & xGun & "*'", "**", "*")
                   UyGun_Rs.Filter = xFiltre
                   If UyGun_Rs.RecordCount > 0 Then dzTarih(i, 2) = UyGun_Rs("Kisi"): UyGun_Rs("NobetSay") = UyGun_Rs("NobetSay") + 1
                End If
        Next i
Sayfa1.Range("A2").Resize(xAySon, 2) = dzTarih
End Sub
 
I

irfnal

Katılım
15 Mayıs 2020
Mesajlar
20
Excel Vers. ve Dili
2010 Türkçe
Merhaba üzerinden biraz süre geçmiş ama ben de sizlerden yardım isteyebilir miyim?

Aslıda bir nöbet çizelgem var sadece bir nöbet bölgesini ve bir gezen bölgeyi boş bıraktım öğretmen sayısı yetmiyor diye oraya çit nöbet yazıyorum aslında kendim elle yapıyorum ama belki bir kodla otomatik yapabilirim diye düşündüm. Yani şu an tek yapmak istediğim. Excel dosyasındaki gibi öğretmenlerin isimlerinin alt alta sıralandığı ve yan tarafta gün için uygnluklarına göre çift nöbet için yerleştirme yapmak istiyorum. Bakın burada olduğu gibi bir liste hazırlıyorum sonra o sarı ile gösterilen yerlere öğretmenlerin ders programlarının uygunluğuna göre ikinci bir nöbet veriyorum 24 öğretmen var. ilk hafta çift nöbet tutana tekrar denk gelmeyecek şekilde diğer öğretmenlerin uygunluklarına göre butona tekrar bastığımda ikinci haftayı oluştursun istiyorum.








Mesala burada düğmeye bir kere bastığımda bana 1.haftaya pazartesi iki kişi diğer günler birer kişi olacak şekilde uygun kişileri versin. sonraki haftayı da nöbet verdiklerine vermeden diğerlerine versin tekrar butona basınca buşekilde kimse kamayana kadar devam edip sonra tekrar başa. Kodlarda yanlışlık yok gibi duruyor ama doğru çalışmıyor.


İndir Nobet Cizelgesi (1) xlsm

Dosyayı indir Nobet Cizelgesi (1) xlsm
dosya.co
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst