Skip to main content

AccessTr.neT


Cüz Dağıtım Programı

Cüz Dağıtım Programı

#7
Dağılımı yaparken kişilere 1er birer mi dağıtılacak? Mesela 1. kişi 3 istemiş, 2. kişi 4, 3. kişi 2 ....
Önce 1.ye 1, 2.ye 1, 3.ye 1 ..... dağıtılıp sonra kalmissa tekrar en başa mı dönülecek yoksa önce 1.ye 3, 2.ye 4, 3.ye 2 gibi mi dağıtılacak?
Cevapla
#8
MERHABA,
örneğin ahmet, 3 cüz istemiş, sıradaki ilk kişiyse 1-2-3.cüz verilir
mehmet 2 istemiş, 4-5 .cüz
kadir, 1 istemiş, 6. cüz
gibi sırayla verilebilir.

ama bir sonraki haftaya geçildiğinde tekrar dağıtım yaparken bu vermiş olduğu cüzleri yine aynı kişelere vermeyecek, başka cüz verecek,

(önemli olan 30 cüzün dağıtımı, ve kişilere vermiş olduğu cüz'ü bir sonraki hafta vermeyecek, başka cüz verecek. )
taki 30 cüz tamamlandı ise o zaman aynı cüzleri vermeye başlayacak...
Cevapla
#9
biraz geç oldu ama dilerim işe yarar
aşağıdaki kod cüzü dağıtmak için ama şöyle bir sorun vardı: dağıtmaya 1'den başlayınca sırayla gittiği için bazen 29 ve 30 gibi sonlardaki cüzler, kişi aynı cüzleri alamayacağı için dağıtılmıyordu. o nedenle cüz dağıtma sıralamasını rasgele ayarlamaya çalıştım ama raslantısallık'tan kaynaklanan sebepler yine de sona kalanların yine yukardaki akıbete uğrama ihtimali var. bunu engellemek için dağıtımdan sonra  -cüz eklenebileceği halde- eklenmemiş kalan cüzleri dağıtmak için 5 defaya kadar dağıtma döngüsü tekrar çalışıyor ama maalesef kesin garanti veremiyorum
Public Sub CuzDagitFonk()

Dim sht As Worksheet
Set sht = Sayfa1
Sonstr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'TamCuz = ",1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,"
For HaftaSay = 1 To 8
HaftaCuz = TamCuzFnk
    If sht.Cells(1, HaftaSay * 3 + 1).Value = 1 Then
Bastan:
    tekSay = 0
    sht.Range(Cells(2, HaftaSay * 3), Cells(Sonstr, HaftaSay * 3 + 1)).ClearContents
        For x = 2 To Sonstr
        KisiCuz = ""
        Set Rng = sht.Range("A" & x)
            If HucreGetir(Rng) = True And (Not IsNull(Rng.Offset(0, 1)) And Rng.Offset(0, 1) <> "") Then
                CSy = Rng.Offset(0, 1).Value
                TmpKisiCuz = sht.Range("C" & x) & "," & sht.Range("I" & x) & "," & sht.Range("L" & x) & "," & sht.Range("O" & x) & "," & _
                          sht.Range("R" & x) & "," & sht.Range("U" & x) & "," & sht.Range("X" & x)
                         
                  TmpDizi = Split(TmpKisiCuz, ",")
                  TmpHaftaCuz = HaftaCuz
                  For Each Item In TmpDizi
                      If Item <> "" Then TmpHaftaCuz = Replace(TmpHaftaCuz, "," & Item & ",", ",")
                  Next Item
             
               
                For CzSay = 1 To CSy
                CuzSil = Split(TmpHaftaCuz, ",")(1)
                If CuzSil = "" Then
                    sht.Cells(x, HaftaSay * 3).Value = Mid(KisiCuz, 2)
                    GoTo SonrakiHafta '10
                End If
                    KisiCuz = KisiCuz & "," & CuzSil
                    HaftaCuz = Replace(HaftaCuz, "," & CuzSil & ",", ",")
                    TmpHaftaCuz = Replace(TmpHaftaCuz, "," & CuzSil & ",", ",")
                Next CzSay
                sht.Cells(x, HaftaSay * 3).Value = Mid(KisiCuz, 2)
            End If
        Next x
        If Len(Replace(HaftaCuz, ",", "") & "") > 0 Then
            tekSay = tekSay + 1
            If tekSay = 6 Then GoTo SonrakiHafta
            GoTo Bastan
        End If
    End If
SonrakiHafta:
10
Next HaftaSay

End Sub
hücredeki checkbox seçili mi kontrolü

Function HucreGetir(ByVal Rng As Range) As Boolean
Dim cb As CheckBox
                     
        For Each cb In Sayfa1.CheckBoxes
            If cb.TopLeftCell.Address = Rng.Address Then HucreGetir = cb.Value
        Next cb
End Function
tüm cüzleri alma kodu

Function TamCuzFnk() As String
    Dim x() As Variant
    x = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30)
    x = Resample(x)
    TamCuzFnk = "," & Join(x, ",") & ","
End Function
cüzlerin sıralamasını değiştirme kodu

Function Resample(data_vector() As Variant) As Variant()
    Dim shuffled_vector() As Variant
    shuffled_vector = data_vector
    Dim i As Long
    For i = UBound(shuffled_vector) To LBound(shuffled_vector) Step -1
        Dim t As Variant
        t = shuffled_vector(i)
        Dim j As Long
        j = Application.RandBetween(LBound(shuffled_vector), UBound(shuffled_vector))
        shuffled_vector(i) = shuffled_vector(j)
        shuffled_vector(j) = t
    Next i
    Resample = shuffled_vector
End Function
.rar CÜZ-PAYLAŞIM-prg_hy3.rar (Dosya Boyutu: 35,35 KB | İndirme Sayısı: 16)
Cevapla
#10
sn üstad, ilgilenip ayırdığınız zaman ve emeğiniz için çok teşekkürler.
cüz dağıtımını doğru yapmıyor maalesef,
sanırım manuele devam Img-grin
iyi günler.
Cevapla
#11
Nerede hata veriyor?

Denemelerimde sonuç doğru çıkıyordu.
Cevapla
#12
(02/07/2021, 08:52)berduş yazdı: Nerede hata veriyor?

Denemelerimde sonuç doğru çıkıyordu.

[Resim: do.php?img=11128]

cüz dağıtımında, önceki haftada vermiş olduğu cüzün aynısını verdiği oluyor.
ben birkaç tanesini renk ve çizgilerle belirtmeye çalıştım.


teşekkür ederim.
Son Düzenleme: 02/07/2021, 09:44, Düzenleyen: karacahil.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da