Sayı Üret ve Dağıt

Mikdad · 20 Mart 2023

Selamun Aleykum Dostlarım, yardımcı olursanız Minnettar Kalırım.

F2 Hücresine yazılan Sayı kadar B Sutununda bulunan isimlerin C sutununda yer alan sayı kadar dağıtım yapacak
Örneğin. B2 de Abidin'e 1 tane sayı verirken, B3 teki Acar a 5 tane sayı verecek ve bu sayılar arasında da - Tire Ekleyecek

Bir Kişiye aynı Sayı verilmeyecek,
Örneğin B2 Hücresinde bulunan Acar'a 5 sayı verilirken aynı sayıdan iki tane verilmemeli (1-5-7-6-8) şeklinde vermelidir.

Dağıtılacak Sayılar 60 ta olsa 90 da olsa 30 üzerinden yani 1-30 arası sayı verecek.
Eğer F2 sutununa 90 yazılacak olursa otomatikmen her bir sayıdan 3 er adet dağıtılmış olacaktır.
İmkan dahilinde aynı kişiye aynı sayı verilmeyecek.

Örnekte olduğu gibi F2 Sutununa 60 yazıldı ama C Sutunu toplamı 57 tuttuysa eksik kalan
hangi sayılar olduğunu E Sutununa yazacak.

Genel itibariyle F2 hücresine yazılan sayı kadar C sutununu baz alarak dağıtım yapacak ve D stununa yazacak.
Eğer 30 yazıldı ise 1-30 arası sadece 1er adet olacak, 60 yazılırsa 1-30 arası 2şer adet,
90 yazılırsa 1-30 arası 3 er adet yazacak

F2 Hücresine sürekli 30 ve katları yazılacak.

veyselemre · 20 Mart 2023

Kod:

Sub test()
    Dim dagit, liste, dagitilacak, i, ii, say1, say2, tmp, dic, kys, say, al, ky
    Range("A2:C" & Cells(Rows.Count, 3).End(3).Row).Sort [C2], xlDescending
    Range("D2:D" & Cells(Rows.Count, 3).End(3).Row).ClearContents
    liste = Range("C2:C" & Cells(Rows.Count, 3).End(3).Row).Value
    dagit = Range("F2").Value
    ReDim dagitilacak(1 To dagit)

    For i = 1 To (dagit / 30)
        For ii = 1 To 30
            dagitilacak((i - 1) * 30 + ii) = ii
        Next ii
    Next i

    For i = 1 To dagit * 5
        say1 = WorksheetFunction.RandBetween(1, dagit)
        say2 = WorksheetFunction.RandBetween(2, dagit)
        tmp = dagitilacak(say1)
        dagitilacak(say1) = dagitilacak(say2)
        dagitilacak(say2) = tmp
    Next i

    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To dagit
        dic.Item(i) = dagitilacak(i)
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(liste)
            .RemoveAll
            If dic.Count = 0 Then GoTo cikis
            kys = dic.keys
            say = 0
            For ii = 1 To liste(i, 1)
                Do
                    ky = kys(say)
                    al = dic(ky)
                    If al = "" Then Stop
                    say = say + 1
                Loop Until Not .exists(al)
                .Item(al) = Null
                dic.Remove (ky)
            Next ii
            Cells(i + 1, "D").Value = Join(.keys, "-")
        Next i
    End With

cikis:
    Range("A2:D" & Cells(Rows.Count, 3).End(3).Row).Sort [A2], xlAscending
    Range("E2").Value = dic.Count
End Sub

Mikdad · 21 Mart 2023

veyselemre' Alıntı:

Kod:

Sub test()
    Dim dagit, liste, dagitilacak, i, ii, say1, say2, tmp, dic, kys, say, al, ky
    Range("A2:C" & Cells(Rows.Count, 3).End(3).Row).Sort [C2], xlDescending
    Range("D2:D" & Cells(Rows.Count, 3).End(3).Row).ClearContents
    liste = Range("C2:C" & Cells(Rows.Count, 3).End(3).Row).Value
    dagit = Range("F2").Value
    ReDim dagitilacak(1 To dagit)

    For i = 1 To (dagit / 30)
        For ii = 1 To 30
            dagitilacak((i - 1) * 30 + ii) = ii
        Next ii
    Next i

    For i = 1 To dagit * 5
        say1 = WorksheetFunction.RandBetween(1, dagit)
        say2 = WorksheetFunction.RandBetween(2, dagit)
        tmp = dagitilacak(say1)
        dagitilacak(say1) = dagitilacak(say2)
        dagitilacak(say2) = tmp
    Next i

    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To dagit
        dic.Item(i) = dagitilacak(i)
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(liste)
            .RemoveAll
            If dic.Count = 0 Then GoTo cikis
            kys = dic.keys
            say = 0
            For ii = 1 To liste(i, 1)
                Do
                    ky = kys(say)
                    al = dic(ky)
                    If al = "" Then Stop
                    say = say + 1
                Loop Until Not .exists(al)
                .Item(al) = Null
                dic.Remove (ky)
            Next ii
            Cells(i + 1, "D").Value = Join(.keys, "-")
        Next i
    End With

cikis:
    Range("A2:D" & Cells(Rows.Count, 3).End(3).Row).Sort [A2], xlAscending
    Range("E2").Value = dic.Count
End Sub

Selamun aleykum hocam Allah razı olsun süper olmuş ellerinize yüreğinize sağlık.
Eksik Kalan Cüz E2 de kaç cüzün eksik kaldığını gösteriyor ama hangi sayıların eksik olduğunu yazmıyor hocam . yani örnek olarak 5-7-8 sayıları eksik ise onu yazdırabilir miyiz.

veyselemre · 21 Mart 2023

Aleyküm selam, biraz düzenlendi.

Kod:

Sub test()
    Dim dagit, liste, dagitilacak, i, ii, iii, say1, say2, tmp, dic, kys, say, al, ky
    Range("A2:C" & Cells(Rows.Count, 3).End(3).Row).Sort [C2], xlDescending
    Range("D2:E" & Cells(Rows.Count, 3).End(3).Row).ClearContents
    liste = Range("C2:C" & Cells(Rows.Count, 3).End(3).Row).Value
    dagit = Range("F2").Value
    ReDim dagitilacak(1 To 30)

    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To (dagit / 30)
        For ii = 1 To 30
            dagitilacak(ii) = ii
        Next ii

        For ii = 1 To 100
            say1 = WorksheetFunction.RandBetween(1, 30)
            say2 = WorksheetFunction.RandBetween(1, 30)
            tmp = dagitilacak(say1)
            dagitilacak(say1) = dagitilacak(say2)
            dagitilacak(say2) = tmp
        Next ii

        For ii = 1 To 30
            dic.Item((i - 1) * 30 + ii) = dagitilacak(ii)
        Next ii
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(liste)
            .RemoveAll
            If dic.Count = 0 Then GoTo cikis
            kys = dic.keys
            say = 0
            For ii = 1 To liste(i, 1)
                Do
                    ky = kys(say)
                    al = dic(ky)
                    If al = "" Then Stop
                    say = say + 1
                Loop Until Not .exists(al)
                .Item(al) = Null
                dic.Remove (ky)
            Next ii
            Cells(i + 1, "D").NumberFormat = "@"
            kys = .keys
            If .Count > 1 Then
                For ii = 0 To UBound(kys) - 1
                    For iii = ii + 1 To UBound(kys)
                        If kys(ii) > kys(iii) Then
                            tmp = kys(ii)
                            kys(ii) = kys(iii)
                            kys(iii) = tmp
                        End If
                    Next iii
                Next ii
            End If
            Cells(i + 1, "D").Value = Join(kys, "-")
        Next i
    End With

cikis:
    Range("A2:D" & Cells(Rows.Count, 3).End(3).Row).Sort [A2], xlAscending
    If dic.Count > 0 Then
        With Range("E2").Resize(dic.Count)
            .Value = Application.Transpose(dic.items)
            .Sort Range("E2")
        End With

    End If
End Sub

Mikdad · 21 Mart 2023

veyselemre' Alıntı:

Aleyküm selam, biraz düzenlendi.

Kod:

Sub test()
    Dim dagit, liste, dagitilacak, i, ii, iii, say1, say2, tmp, dic, kys, say, al, ky
    say = Cells(Rows.Count, 3).End(3).Row
    With Range("D2:D" & say)
        .NumberFormat = "General"
        .Formula = "=RANDBETWEEN(1,500)"
        .Value = .Value
    End With
    Range("A2:D" & say).Sort [C2], xlDescending, [d2]

    Range("D2:E" & say).ClearContents
    liste = Range("C2:C" & say).Value
    dagit = Range("F2").Value
    ReDim dagitilacak(1 To dagit)

    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To (dagit / 30)
        For ii = 1 To 30
            dagitilacak(ii) = ii
        Next ii

        For ii = 1 To 5
            say1 = WorksheetFunction.RandBetween(1, 30)
            say2 = WorksheetFunction.RandBetween(1, 30)
            tmp = dagitilacak(say1)
            dagitilacak(say1) = dagitilacak(say2)
            dagitilacak(say2) = tmp
        Next ii

        For ii = 1 To 30
            dic.Item((i - 1) * 30 + ii) = dagitilacak(ii)
        Next ii
    Next i

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(liste)
            .RemoveAll
            If dic.Count = 0 Then GoTo cikis
            kys = dic.keys
            say = 0
            For ii = 1 To liste(i, 1)
                Do
                    ky = kys(say)
                    al = dic(ky)
                    If al = "" Then Stop
                    say = say + 1
                Loop Until Not .exists(al)
                .Item(al) = Null
                dic.Remove (ky)
            Next ii
            Cells(i + 1, "D").NumberFormat = "@"
            kys = .keys
            If .Count > 1 Then
                For ii = 0 To UBound(kys) - 1
                    For iii = ii + 1 To UBound(kys)
                        If kys(ii) > kys(iii) Then
                            tmp = kys(ii)
                            kys(ii) = kys(iii)
                            kys(iii) = tmp
                        End If
                    Next iii
                Next ii
            End If
            Cells(i + 1, "D").Value = Join(kys, "-")
        Next i
    End With

cikis:
    Range("A2:D" & Cells(Rows.Count, 3).End(3).Row).Sort [A2], xlAscending
    If dic.Count > 0 Then
        With Range("E2").Resize(dic.Count)
            .Value = Application.Transpose(dic.items)
            .Sort Range("E2")
        End With
    End If
End Sub

hocam sayı toplamı 61 dağıtılacak sayı 58 dediğimizde bu şekilde hata veriyor.

veyselemre · 21 Mart 2023

Mikdad' Alıntı:
F2 Hücresine sürekli 30 ve katları yazılacak.

Talebinize istinaden hazırlandı. Benden bu kadar.

Mikdad · 21 Mart 2023

veyselemre' Alıntı:
Talebinize istinaden hazırlandı. Benden bu kadar.

Allah razı olsun hocam . Siz söyleyince fark ettim 30 un katları kısmını . Hakkınızı lütfen helal edin . Herşey için teşekkür ederim

Sayı Üret ve Dağıt

Mikdad

Ekli dosyalar

veyselemre

Özel Üye

Mikdad

veyselemre

Özel Üye

Mikdad

Ekli dosyalar

veyselemre

Özel Üye

Mikdad