• DİKKAT

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

Yüzdeye Göre Sayı Seçimi

R

rafetgulmez

Katılım
21 Mart 2009
Mesajlar
60
Excel Vers. ve Dili
2007 türkçe
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............
 
Son düzenleme:
Senide uyku tutmadı herhalde... :) Anlatmak istediğimle uzaktan yakından alakası yok... Yinede sağol ;)
 
rafetgulmez' Alıntı:
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............
Genişletmek için tıkla ...
Merhaba
Örnek olarak bir dosya hazırlayın. Anlatmak istediğiniz bu şekilde anlaşılmıyor.
 
Arkadaşlar perşembeye kadar bu konuyla ilgili çözüm üretmem gerekiyor..... :yardim:
 
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
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
 
Korhan Ayhan' Alıntı:
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
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
Genişletmek için tıkla ...


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

Ekli dosyalar

Selamlar,

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

Korhan Ayhan' Alıntı:
Selamlar,

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

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)
 
Son düzenleme:
Selamlar,

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

Ekli dosyalar

Son düzenleme:
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.

Kod: 
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
 

Ekli dosyalar

korhan ayhan' Alıntı:
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.

Kod: 
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
Genişletmek için tıkla ...

eyvallah hocam bu da çok makbule geçti... Tekrar tşk ettim ilginizden dolayı...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst