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

[Mikdad]

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

 

[ÖmerFaruk]

Hatim Başlangıç Sayısı ne işe yarayacak?

 

[Mikdad]

Hatim başlangıç ise kaçıncı hatimde olduğumuz gösteriyor. yani döküm sayfasında gösterilecek

 

[Mikdad]

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

 

[ÖmerFaruk]

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ü?

 

[Mikdad]

İ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

 

[ÖmerFaruk]

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.

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

 

[veyselemre]

Örneği inceleyin. Daha fazlası benden çıkmaz.

 

[Mikdad]

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

 

[ÖmerFaruk]

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.

 

[Mikdad]

Hemen Test Ediyorum hocam

 

[Mikdad]

ÖmerFaruk Hocam Rabbim Sizlerden Razı Olsun. İnşAllah Bu hatimlerde sizlerinde Sevabı oldu.
VeyselEmre hocam sizlerden de Rabbim Razı Olsun

 

[Mikdad]

Ö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

 

[ÖmerFaruk]

8.haftaya kadar sorun çıkarmadan çalışıyor mu?

 

[Mikdad]

evet hocam ama ondan sonra donuyor
listeye 30 kişi ekleyin hepsini aktif edin ondan sonra dağıtımı deneyin hatayı göreceksiniz.

 

[ÖmerFaruk]

Tamam bakıyorum, kodları biraz değiştireceğim.

 

[Mikdad]

Ömer Faruk hocam bakma imkanınız Oldu mu?

 

[ÖmerFaruk]

Biraz kastırdım ama sanırım oldu.

 

[Mikdad]

Biraz kastırdım ama sanırım oldu.

Değerli Hocam Rabbim Hayrınızı Kabul ve Makbul Eylesin İnşAllah. Programda Hali Hazırda hiçbir sıkıntı yok . tekrar teşekkür ederim.

 

[TURKOLOG]

Biraz kastırdım ama sanırım oldu.

Dosyayı harici link olarak paylaşabilecek olan var mı acaba