Belirli koşula göre rastgele değer

[myefsane]

Merhaba,

A1=20
B1=15
C1=25
D1=10
F1=30
Bu değerler toplam 100 olacak şekilde değişecek.

A2= A1 de ki değeri geçmeyecek bir sayı
B2= B1 de ki değeri geçmeyecek bir sayı
C2= C1 de ki değeri geçmeyecek bir sayı
D2= D1 de ki değeri geçmeyecek bir sayı
F2= F1 de ki değeri geçmeyecek bir sayı

ve A2 +B2+C2+D2+F2 = G3 hücresine kaç yazıldıysa ona

bu formüle edilir mi?

 

[Tevfik_Kursun]

Merhaba Arkadaşım,

Sub dene()
    Range("A2:G3").ClearContents
        For i = 1 To 5
            Randomize
            x = WorksheetFunction.RandBetween(1, Cells(1, i) - 1)
            Cells(2, i).Value = x
        Next i
    Cells(3, 7) = WorksheetFunction.Sum(Range(Cells(2, 1), Cells(2, 5)))
End Sub

işinizi görür mü?

 

[Tevfik_Kursun]

Merhaba Arkadaş,
Yukarıdakinde A1:E1 arasını siz değiştiriyorsunuz.
Eğer ilk A1:E1 inde değişmesini istiyorsanız

Sub Toplam_Belli()
    Range("A1:G3").ClearContents
basa:
    Say = Say + 1
    If Say = 4 Then MsgBox ("tekrar deneyin"): GoTo Bitir
    Range("A1:E1").ClearContents
        For i = 1 To 4
            Randomize
            x = WorksheetFunction.RandBetween(2, 40)
            Cells(1, i).Value = x
        Next i
    Cells(1, 5) = 100 - WorksheetFunction.Sum(Range(Cells(1, 1), Cells(1, 4)))
    If Cells(1, 5) < 2 Then GoTo basa
Bitir:
    If Cells(1, 5) < 0 Then
        End
      Else
        For i = 1 To 5
            Randomize
            x = WorksheetFunction.RandBetween(1, Cells(1, i) - 1)
            Cells(2, i).Value = x
        Next i
        Cells(2, 7) = WorksheetFunction.Sum(Range(Cells(2, 1), Cells(2, 5)))
    End If
End Sub

istediğiniz budur umarım.

 

[myefsane]

1. satırdaki hücre değerleri sabit olacak. Onu ben ayarlarım ama toplam benim istediğim olacak. yani 70 i 5 sayıyla nasıl bulurum gibi

 

[myefsane]

İstediğime çok yakın ama toplamı benim vermem gerekiyor. Yani 70 i yukarıdaki sayılar dan büyük olmayacak şekilde oluşturmak

 

[Tevfik_Kursun]

Ne demek istediğinizi anlamadım, örnek yüklerseniz bakarım.

 

[myefsane]

Merhaba Örnek Dosya burada

 

[alicimri]

Buna benzer bir soruya bir çalışma yapmıştım boş bir sayfada deneyin. C1 hücresine bir sayı yazın (örneğin 70) makroyu çalıştırın, A sütununda toplamları C1 hücresindeki sayı olan beş sayı oluşturacaktır.

Sub makro()
Application.ScreenUpdating = False
dön:
Columns(1).Clear
i = 1
Do While i < 6
sayi = Application.RandBetween(1, Range("C1") \ 3)
Cells(i, 1).Value = sayi
i = i + 1
Loop
If Application.Sum(Range("A1:A10")) <> Range("C1").Value Then GoTo dön
Range("A1:A5").Sort Key1:=Range("A1"), Order1:=xlDescending
Application.ScreenUpdating = True
End Sub

 

[alicimri]

Sizin çalışmanıza uygulanmış örnek ekte

deneme1.xlsm dosyasını indir - download

deneme1.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[myefsane]

Merhaba makro çok güzel. Tek sorunum acaba bu 5 sayıyı belli koşullardan küçük olacak şekilde ayarlamam lazım

 

[alicimri]

Örnek dosyanızda öyle bir durum mu var.

 

[myefsane]

Evet Üstte yazan değerlerden hepsi küçük

 

[alicimri]

Son sıradaki Remzi ikinci şartınıza uyuyor mu

 

[alicimri]

Aşağıdaki kod tam olarak ikinci şartı karşılamıyor, onu beceremedim. Ancak şartı yerine getirmeyen hücreleri kırmızı yapıyor. Manuel düzeltmek gerekiyor. İşinize yararsa kullanın. Kodları, #9 mesajdaki örnek dosyaya yapıştırarak deneyin. Düğmeye teke düşürene kadar bir kaç kere tıklayın. Bazen doğru sonuç verebilir

Sub makro()
Application.ScreenUpdating = False
son = Cells(Rows.Count, 1).End(3).Row
Range("B3:F" & son).Interior.Color = xlNone
For e = 2 To son
dön:
Range("B" & e & ":F" & e).ClearContents
i = 1
Do While i < 6
sayi = Application.RandBetween(0, Range("G" & e) \ 4)
Cells(e, i + 1).Value = sayi
i = i + 1
Loop
If Application.Sum(Range("B" & e & ":F" & e)) <> Range("G" & e).Value Then GoTo dön
Next
Range("B2:F" & son).Copy
    Range("M1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
   For x = 13 To son + 13
       Columns(x).Sort key1:=Cells(1, x), order1:=xlAscending
Next
Range("M1").CurrentRegion.Copy
Range("B2").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Range("M1").CurrentRegion.Delete
Set aa = Range("B3:F" & son)
For e = 1 To aa.Count
If aa(e) > Range(aa(e).Address).Offset(-1, 0) Then
aa(e).Interior.Color = 255
End If
Next
Application.ScreenUpdating = True
End Sub

 

[alicimri]

Ekli dosya iki şartı da 1 dakika içinde hallediyor.

deneme2.xlsm dosyasını indir - download

deneme2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Rastgele_Not()
    Dim Rng As Range
    
    For Each Rng In Range("G3:G" & Cells(Rows.Count, 1).End(3).Row)
        If Rng.Value = Range("G2").Value Then
            Rng.Offset(, -5).Resize(, 5).Value = Range("B2:F2").Value
        Else
            Rng.Offset(, -5).Resize(, 5).Formula = "=RANDBETWEEN(1,B$2)"
10          If WorksheetFunction.Sum(Rng.Offset(, -5).Resize(, 5)) = Rng.Value Then
                Rng.Offset(, -5).Resize(, 5).Value = Rng.Offset(, -5).Resize(, 5).Value
            Else
                Calculate
                GoTo 10
            End If
        End If
    Next
    
    MsgBox "Not dağılımı tamamlanmıştır.", vbInformation
End Sub

 

[myefsane]

@Korhan Ayhan Bey mükemmel çalışıyor. Elinize sağlık. Not girmeyince çok fazla dönüyor sadece

 

[Korhan Ayhan]

1. satırdaki hücre değerleri sabit olacak. Onu ben ayarlarım ama toplam benim istediğim olacak. yani 70 i 5 sayıyla nasıl bulurum gibi