• DİKKAT

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

Sayı Üret ve Dağıt

  • 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, 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.








 

Ekli dosyalar

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
 
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
Genişletmek için tıkla ...
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.
 
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
 
Son düzenleme:
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
Genişletmek için tıkla ...
hocam sayı toplamı 61 dağıtılacak sayı 58 dediğimizde bu şekilde hata veriyor.
 

Ekli dosyalar

  • hata1.png
    hata1.png
    18.9 KB · Görüntüleme: 2
  • hata2.png
    hata2.png
    18.8 KB · Görüntüleme: 2
veyselemre' Alıntı:
Talebinize istinaden hazırlandı. Benden bu kadar.
Genişletmek için tıkla ...
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst