• DİKKAT

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

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

  • Konbuyu başlatan Konbuyu başlatan NeCRiS
  • Başlangıç tarihi Başlangıç tarihi
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
 
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.


vfrb6h4p.png


-T4AWtuK.png




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)

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