Yüzdeye Göre Sayı Seçimi

[rafetgulmez]

1 den 4 kadar sayılarımız var diyelim ve bu sayıları "yüzdelerine" göre seçip önceden belirlediğimiz hücrelere yazılmasını istiyoruz. (Toplamda 10 sayı seçilecek)

1 yüzdesi %10
2 yüzdesi %20
3 yüzdesi %30
4 yüzdesi %40
toplam = %100

sayılarda şu şekilde olmalı= 4,2,1,3,4,3,4,2,4,3 (karışık)

Forumda buna benzer bir konu buldum fakat örnek dosyası "indirilemiyor"... http://www.excel.web.tr/f47/yuzdeye-gore-sayy-secimi-t43766.html

yardımlarınızı bekliyorum............

 

[acanimoglu]

yüzde

ekteki dosya işinize yarar mı acaba

 

[rafetgulmez]

Senide uyku tutmadı herhalde... Anlatmak istediğimle uzaktan yakından alakası yok... Yinede sağol

 

[rafetgulmez]

Yardımcı olacak kimse yok mu?

 

[Mahir64]

1 den 4 kadar sayılarımız var diyelim ve bu sayıları "yüzdelerine" göre seçip önceden belirlediğimiz hücrelere yazılmasını istiyoruz. (Toplamda 10 sayı seçilecek)

1 yüzdesi %10
2 yüzdesi %20
3 yüzdesi %30
4 yüzdesi %40
toplam = %100

sayılarda şu şekilde olmalı= 1,2,2,3,3,3,4,4,4,4 (sıralı yada karışık olabilir)

Forumda buna benzer bir konu buldum fakat örnek dosyası "indirilemiyor"... http://www.excel.web.tr/f47/yuzdeye-gore-sayy-secimi-t43766.html

yardımlarınızı bekliyorum............

Merhaba
Örnek olarak bir dosya hazırlayın. Anlatmak istediğiniz bu şekilde anlaşılmıyor.

 

[rafetgulmez]

Merhaba
Örnek olarak bir dosya hazırlayın. Anlatmak istediğiniz bu şekilde anlaşılmıyor.

Dosyayı ekledim hocam...

 

[rafetgulmez]

Arkadaşlar perşembeye kadar bu konuyla ilgili çözüm üretmem gerekiyor..... :yardim:

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub YÜZDELERE_GÖRE_RASTGELE_DAĞIT()
    Dim SAYI  As Double, SÜTUN As Byte
    
    Range("E10:N10").ClearContents
    SÜTUN = 5
BAŞLA:
    Randomize
    SAYI = WorksheetFunction.Round(Rnd * WorksheetFunction.Max(Range("E4:H4")), 2)
    If WorksheetFunction.CountIf(Range("E4:H4"), SAYI) > 0 Then
        Cells(10, SÜTUN) = Range("E4:H4").Find(SAYI * 100).Offset(-1, 0)
        SÜTUN = SÜTUN + 1
    Else
        GoTo BAŞLA
    End If
    
    If Range("N10") = "" Then GoTo BAŞLA
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[rafetgulmez]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub YÜZDELERE_GÖRE_RASTGELE_DAĞIT()
    Dim SAYI  As Double, SÜTUN As Byte
    
    Range("E10:N10").ClearContents
    SÜTUN = 5
BAŞLA:
    Randomize
    SAYI = WorksheetFunction.Round(Rnd * WorksheetFunction.Max(Range("E4:H4")), 2)
    If WorksheetFunction.CountIf(Range("E4:H4"), SAYI) > 0 Then
        Cells(10, SÜTUN) = Range("E4:H4").Find(SAYI * 100).Offset(-1, 0)
        SÜTUN = SÜTUN + 1
    Else
        GoTo BAŞLA
    End If
    
    If Range("N10") = "" Then GoTo BAŞLA
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Maalesef hocam yüzdelere göre seçmiyor.. uyguladığım dosyayı ekledim.

 

[Korhan Ayhan]

Selamlar,

Eklediğiniz dosyada butona tıkladığımda sayılarda dağılım oluyor. Siz farklı bir işlemmi istiyor sunuz?

 

[rafetgulmez]

Devam-1

Selamlar,

Eklediğiniz dosyada butona tıkladığımda sayılarda dağılım oluyor. Siz farklı bir işlemmi istiyor sunuz?

Hocam %(yüzde) değerlerine göre dağıtmıyor...

Atıyorum bizim örnekte 4 sayısının yüzdesi %40 .... 1 sayısının ise %10 yani 4 e göre 1 gelme ihtimali %30 daha az "olmalı"... Farketmişsinizdir % değerlerinin toplamı herzaman %100 olacak ....

Matematiksel olarak anlatacak olursak: sayılar 1,2,3,4 bunları 100 birim içindeki rakamsal değerleri: 1+2+3+4 = 10 buna göre: 1 için (1*10)/100 =0,1=%10 ..... 4 için (4*10)/100 = 0,4 = %40

ÖZETLE: Butona bastığımızda dağılım şu şekilde olmalı (örneğimizdeki yüzde oranlarına göre): 4 - 4 - 2 - 1 - 3 - 2 - 3 - 4 - 3 - 4 (1 adet 1; 2 adet 2 ; 3 adet 3 ve 4 adet 4 ......karışık şekilde)

 

[Korhan Ayhan]

Selamlar,

Konuyu daha iyi anlamak adına örnek dosya üzerinde bir kaç farklı örneği açıklayarak verebilirmisiniz.

 

[rafetgulmez]

Selamlar,

Konuyu daha iyi anlamak adına örnek dosya üzerinde bir kaç farklı örneği açıklayarak verebilirmisiniz.

Hocam en sade haline getirdim... Dosya ekte... İlginiz için tşk. ederim.

 

[ffff7]

Dosyanız ektedir.

 

[rafetgulmez]

ÇÖZÜLDÜ

Dosyanız ektedir.

eyvallah hocam tamamdır... Yardımcı olmaya çalışan diğer arkadaşlara da teşekkür ederim....

 

[Korhan Ayhan]

Selamlar,

Bende önerdiğim kodu revize ederek en fazla 2 aynı sayı yanyana gelecek şekilde dağıtma işlemini ayarladım. Ekteki örnek dosyayı incelermisiniz.

Option Explicit
 
Sub YÜZDELERE_GÖRE_RASTGELE_DAĞIT()
    Dim SAYI As Long, SÜTUN As Integer, ADET As Integer, KONTROL As Byte
    
    Range("E11:CZ11").ClearContents
    SÜTUN = 5
    
BAŞLA:
    Randomize
    SAYI = Int(Rnd * WorksheetFunction.Max(Range("E3:H3")) + 1)
    If WorksheetFunction.CountIf(Range("E3:H3"), SAYI) > 0 Then
        ADET = Range("E3:H3").Find(SAYI).Offset(3, 0)
        If WorksheetFunction.CountIf(Range("E11:CZ11"), SAYI) < ADET Then
            If KONTROL = 50 Then
                Range("E11:CZ11").ClearContents
                KONTROL = 0
                SÜTUN = 5
                GoTo BAŞLA
            End If
            If WorksheetFunction.CountIf(Range(Cells(11, SÜTUN - 2), Cells(11, SÜTUN - 1)), SAYI) = 2 Then
                KONTROL = KONTROL + 1
                GoTo BAŞLA
            Else
                Cells(11, SÜTUN) = SAYI
                SÜTUN = SÜTUN + 1
            End If
        Else
            GoTo BAŞLA
        End If
    Else
        GoTo BAŞLA
    End If
        
    If WorksheetFunction.CountIf(Range("E11:CZ11"), Range("E3")) < Range("E6") Then GoTo BAŞLA
    If WorksheetFunction.CountIf(Range("E11:CZ11"), Range("F3")) < Range("F6") Then GoTo BAŞLA
    If WorksheetFunction.CountIf(Range("E11:CZ11"), Range("G3")) < Range("G6") Then GoTo BAŞLA
    If WorksheetFunction.CountIf(Range("E11:CZ11"), Range("H3")) < Range("H6") Then GoTo BAŞLA
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[rafetgulmez]

selamlar,

bende önerdiğim kodu revize ederek en fazla 2 aynı sayı yanyana gelecek şekilde dağıtma işlemini ayarladım. Ekteki örnek dosyayı incelermisiniz.

option explicit
 
sub yüzdelere_göre_rastgele_dağıt()
    dim sayı as long, sütun as ınteger, adet as ınteger, kontrol as byte
    
    range("e11:cz11").clearcontents
    sütun = 5
    
başla:
    Randomize
    sayı = ınt(rnd * worksheetfunction.max(range("e3:h3")) + 1)
    ıf worksheetfunction.countıf(range("e3:h3"), sayı) > 0 then
        adet = range("e3:h3").find(sayı).offset(3, 0)
        ıf worksheetfunction.countıf(range("e11:cz11"), sayı) < adet then
            ıf kontrol = 50 then
                range("e11:cz11").clearcontents
                kontrol = 0
                sütun = 5
                goto başla
            end ıf
            ıf worksheetfunction.countıf(range(cells(11, sütun - 2), cells(11, sütun - 1)), sayı) = 2 then
                kontrol = kontrol + 1
                goto başla
            else
                cells(11, sütun) = sayı
                sütun = sütun + 1
            end ıf
        else
            goto başla
        end ıf
    else
        goto başla
    end ıf
        
    ıf worksheetfunction.countıf(range("e11:cz11"), range("e3")) < range("e6") then goto başla
    ıf worksheetfunction.countıf(range("e11:cz11"), range("f3")) < range("f6") then goto başla
    ıf worksheetfunction.countıf(range("e11:cz11"), range("g3")) < range("g6") then goto başla
    ıf worksheetfunction.countıf(range("e11:cz11"), range("h3")) < range("h6") then goto başla
    
    msgbox "işleminiz tamamlanmıştır.", vbınformation
end sub

eyvallah hocam bu da çok makbule geçti... Tekrar tşk ettim ilginizden dolayı...