• DİKKAT

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

Hatim Cüz Dağıtım Programı

  • Konbuyu başlatan Konbuyu başlatan Mikdad
  • Başlangıç tarihi Başlangıç tarihi
Mikdad

Mikdad

Altın Üye
Katılım
5 Ocak 2006
Mesajlar
333
Excel Vers. ve Dili
365 Türkçe
Selamun aleykum dostlarım,
ekli listede haftalık olarak okumuş olduğumuz hatimler için bir proje taslağı var. bu projede ;
1) her kişinin karşısında kişinin haftalık kaç cüz okuyacağı bilgisi var. kimisi 1 kimisi 3 kimisi 5 vs. Haftalık cüzü dağıt buttonuna tıklandığında 1 haftadan başlayıp 52 haftaya kadar kontrol edecek hangi hafta boşta ise o kişinin karşısında kaç cüz yazıyorsa aralarına - tire işareti ekleyecek şekilde yan yana yazacak.
2)aynı kişiyi bir hatmi tamamlamadan aynı cüz verilmeyecek. yani eğer bilal a 1. cüz verildi ise bilal 30 cüz okumadan tekrar 1. cüz verilmeyecek.
3)Haftalık cüz dağıtımı bittikten sonra Döküm şablonuna ilgili hafta bilgileri aktarılacak.
Şimdiden Allah Hayrınızı Kabul Etsin
 

Ekli dosyalar

Hatim Başlangıç Sayısı ne işe yarayacak?
 
Hatim başlangıç ise kaçıncı hatimde olduğumuz gösteriyor. yani döküm sayfasında gösterilecek
 
Her hafta yani bir hata geçerken oradaki rakam da otomatik 1 artacak. Yani şuna 28 hatmi dağıt dediğimizde 29.hatim olarak değişip artacak
 
Program haftalık olarak mı çalışacak?
İlk hafta tuşa basılınca 1.haftanın değerleri yazılacak.
İkinci hafta tuşa tekrar basıldığında 2.haftanın değerleri,
her yeni hafta için de kişi bazlı olarak her hafta farklı cüz/cüzler verilecek, aynı cüzü ancak 30 cüzü tamamlamışsa verilecek.
Ayrıca her hafta tüm kişilere dağıtılmış olan cüzler muhakkak 30 cüzü de içerecek.

Doğru mudur?

İlaveten kişi diyelim 4 cüz okuyabiliyor.
7. hafta 28 cüz dolacak.
8. hafta sadece kalan 2 cüzü mü okuyacak yoksa kalan 2 cüz + bu iki cüzden farklı olarak yeni 2 cüz mü?
 
İlk yazdığınız her butona tıklandığında yeni haftayı oluşturacak.
İkinci sorduğunuz ise 2+2 şeklinde olacak. Aslında eski hatmini bitirmiş oluyor yeni Hatim den de 2 cüz almış oluyor
 
Döküm sayfasındaki tarih aralığını neye göre aldığınızı bilemediğim için o kısmı ellemedim.
D sütunundaki Aktif/Pasif yaptığınız OptionButtonlarla ilgili de bir şey söylemediniz diye onu da ellemedim.

"8. hafta sadece kalan 2 cüzü mü okuyacak yoksa kalan 2 cüz + bu iki cüzden farklı olarak yeni 2 cüz mü?" Bu soruma 2+2 cevap verdiniz ancak ben yine de 2+0 yaptım. Kodlar çok karışıyor diye.

Aşağıdaki kodları bir modüle içine yerleştirip butona atayabilirsiniz. Ben bir kaç deneme yaptım hata göremedim.
C++: 
Sub Cuzler()
Dim Dizi(1 To 30), Cüz1 As Object, Cüz2 As Object, ListeA, ListeB, Okunan
Dim Wf As WorksheetFunction, CüzNo As Integer, Metin As String, Sh1 As Worksheet, rngCell As Range
    Set Wf = WorksheetFunction
    Set Cüz1 = VBA.CreateObject("Scripting.Dictionary")
    Set Cüz2 = VBA.CreateObject("Scripting.Dictionary")
    Set CüzYaz = VBA.CreateObject("Scripting.Dictionary")
  
    Sütun = 5 + (Range("I4") - 1) * 2
    Son = Range("B" & Rows.Count).End(xlUp).Row
    Columns(Sütun).ColumnWidth = 10
    Columns(Sütun + 1).ColumnWidth = 5
  
    For i = 7 To Son
        For k = Columns("E").Column To Sütun - 2 Step 2
            If Cells(i, k) <> "" Then
                Okunan = Split(Cells(i, k), "-")
                For x = 0 To UBound(Okunan, 1)
                    If Not Cüz1.Exists(Okunan(x) * 1) Then Cüz1.Add Okunan(x) * 1, 0
                Next x
            End If
            If Cüz1.Count = 30 Then Cüz1.RemoveAll
        Next k
      
        Do
        CüzNo = Wf.RandBetween(1, 30)
        If Not Cüz1.Exists(CüzNo) Then
            If Not Cüz2.Exists(CüzNo) Then
                If Not CüzYaz.Exists(CüzNo) Then
                    CüzYaz.Add CüzNo, 0
                    Cüz2.Add CüzNo, 0
                    If Cüz2.Count = 30 Then Cüz2.RemoveAll
                End If
            End If
        End If
        If CüzYaz.Count = Range("C" & i) Then Exit Do
        Loop
        Metin = Join(CüzYaz.Keys, "-")
        Cells(i, Sütun) = Join(CüzYaz.Keys, "-")
        If Cells(i, Sütun).Errors.Item(xlNumberAsText).Value Then Cells(i, Sütun).Errors.Item(xlNumberAsText).Ignore = True
        Cüz1.RemoveAll
        CüzYaz.RemoveAll
    Next i
  
    Set Sh1 = Worksheets("Döküm")
    Sh1.Range("A4:D" & Rows.Count).ClearContents
    Range("A7:B" & Son).Copy
    Sh1.Range("A4").Resize(Son - 6, 2).PasteSpecial xlPasteValues
    Range("A7").Offset(0, Sütun - 1).Resize(Son - 6, 1).Copy
    Sh1.Range("A4").Offset(0, 2).Resize(Son - 6, 1).PasteSpecial xlPasteValues
        For Each rngCell In Sh1.Range("A4").Offset(0, 2).Resize(Son - 6, 1).Cells
            With rngCell
                If .Errors.Item(xlNumberAsText).Value Then .Errors.Item(xlNumberAsText).Ignore = True
            End With
        Next rngCell
    Sh1.Range("A4").Offset(0, 2).Resize(Son - 6, 1).HorizontalAlignment = 2
    Range("I4") = Wf.Min(52, Range("I4") + 1)
    Set Cüz1 = Nothing: Set Cüz2 = Nothing: Set CüzYaz = Nothing: Set Sh1 = Nothing
End Sub
 
Hocam Allah razı olsun aktif pasif kısmı eğer pasif ise o kişiye cüz yazılmayacak. Eğer işaretli eşe cüz verilecek
 
Option Buttonları sildim. Sırasız yerleşmişti zaten. İlgili hücre aralığında Aktif/Pasif şeklinde Veri Doğrulama koydum bu hali daha rahat olur.
 

Ekli dosyalar

ÖmerFaruk Hocam Rabbim Sizlerden Razı Olsun. İnşAllah Bu hatimlerde sizlerinde Sevabı oldu.
VeyselEmre hocam sizlerden de Rabbim Razı Olsun
 
ÖmerFaruk hocam, 22 kişi ekledim listeye ve her 22 kişi de aktif hale getirdim. daha sonra test için cüz dağıt diyorum. 8. haftada excell donuyor ve işlem yapmıyor. sorun nedir acaba
 
8.haftaya kadar sorun çıkarmadan çalışıyor mu?
 
evet hocam ama ondan sonra donuyor
listeye 30 kişi ekleyin hepsini aktif edin ondan sonra dağıtımı deneyin hatayı göreceksiniz.
 
Son düzenleme:
Tamam bakıyorum, kodları biraz değiştireceğim.
 
Ömer Faruk hocam bakma imkanınız Oldu mu?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst