Rastgele Sayı Üretme!

[leumruk]

Değerli Arkadaşlar,
Malum bu konuda pek çok soru geliyor. Benim bir önerim olacak, bu başlık altında bu konuyla ilgili kodları ekleyebilir miyiz? Alternatifler bir başlık altında toplanırsa hangisini kullanacağımıza daha iyi karar verebiliriz.
Ben bu konuyla ilgili gelen ve gelebilecek soruları sıralamaya çalışayım:
1. A1 hücresine 1-100 arasında rastgele sayı üretme.
2. A1 hücresine 1-100 arasında rastgele sayı üretme. 100 sayı tekrarlanana kadar aynı sayı yeniden gelmeyecek. Bittiğinde çekilişin bittiği uyarısını verecek.
3. A1-A100 arası tekrarsız rastgele sayı üretme.
4. A1:A50 arasında yazılı rastgele sayıları B1:B50 arasına rastgele sıralama.
5. A1:A50 arasındaki hücrelerden birini rastgele seçme.
6. A1:A50 arasındaki hücreleri rastgele seçme, seçtiğini bir daha seçmeme.

Şu an aklıma gelenler bunlar, elinde veri olan arkadaşlar paylaşırsa memnun olurum.
Burada olmayıp da aklınıza gelen konuyla ilgili bildiklerinizi de paylaşırsanız, sevinirim.
katkısı olacak arkadaşlara şimdiden teşekkürler.

 

[Levent Menteşoğlu]

Sn leumruk

Bu konuyu bence Beyin Fırtınası başlığına taşıyalım ilgilenen üyelerimiz konu üzerindeki önerilerini paylaşsın.

 

[leumruk]

Olur hocam, nasıl uygun görürseniz. Hatta daha iyi olur. Bu bölüm çok yoğun, konu kaybolup gidebilir.

 

[Levent Menteşoğlu]

Güzel bir konu bu başlıkta arada kaynamayacaktır. Tüm üyelerimizden ilginç öneriler bekliyoruz.

 

[xxcell]

2 numaralı soru bana Tombalayı anımsattı.

Bende (konsepti bozmadan!) 2 numaralı soruya cevaben bir örnek hazırladım.

İlginize sunarım, teşekkürler

 

[Korhan Ayhan]

Selamlar,

1. nolu sorunuzun cevabı; (İki alternatif)

Sub RASTGELE_SAYI_ÜRET_1()
    [A1] = Int((100 * Rnd) + 1)
End Sub

Sub RASTGELE_SAYI_ÜRET_2()
    [A1] = Evaluate("=RASTGELEARADA(1,100)")
End Sub

3. nolu sorunuzun cevabı;

Sub RASTGELE_SAYI_ÜRET_3()
    Dim X As Byte, SAYI As Byte
 
    Columns(1).ClearContents
    For X = 1 To 100
BAŞLA: SAYI = Int((100 * Rnd) + 1)
    If WorksheetFunction.CountIf(Columns(1), SAYI) > 0 Or SAYI = 0 Then GoTo BAŞLA
    Cells(X, 1) = SAYI
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

4. nolu sorunuzun cevabı;

Sub RASTGELE_SAYI_ÜRET_4()
    Dim X As Byte, SAYI As Byte
 
    Columns(2).ClearContents
    For X = 1 To 50
BAŞLA: SAYI = Int((50 * Rnd) + 1)
    If SAYI = 0 Then GoTo BAŞLA
    If Cells(SAYI, 2) = Empty Then
    Cells(SAYI, 2) = Cells(X, 1)
    Else
    GoTo BAŞLA
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

5. nolu sorunuzun cevabı;

Sub RASTGELE_HÜCRE_SEÇ_5()
    Dim X As Byte, SAYI As Byte
 
BAŞLA: SAYI = Int((50 * Rnd) + 1)
    If SAYI = 0 Then GoTo BAŞLA
    Cells(SAYI, 1).Select
End Sub

6. nolu sorunuzun cevabı;

Sub RASTGELE_HÜCRE_SEÇ_6()
    Dim X As Byte, SAYI As Byte
 
BAŞLA: SAYI = Int((50 * Rnd) + 1)
    If SAYI = 0 Then GoTo BAŞLA
    If SAYI <> ActiveCell.Row Then
    Cells(SAYI, 1).Select
    Else
    GoTo BAŞLA
    End If
End Sub

 

[leumruk]

Korhan Hocam,
Teşekkür ederim. Çok güzel bir kaynak oldu.
Bir kaç tane daha aklıma konu geldi:
1. A1: A10 arasındaki hücrelerde bulunan verileri kendi içinde rastgele karıştırma.
2. Aynı şekilde yan yana bulunan birden fazla sütunda bulunan verileri dağılım düzeni birbiriyle aynı olmayacak şekilde rastgele dağıtma.
Syn. Hocam bunlarında çözümü var mı?
Bunların dışında aklınıza gelen başka rastgele dağılım biçimleri varsa, eklerseniz sevinirim.
Saygılar...

 

[leumruk]

1-9 ARASINDA 5 ayrı hücrede Rastgele sayı üretir.

Sub Makro1()
    [B3] = "=INT((RAND()*9)+1)"
    [c3] = "=INT((RAND()*9)+1)"
    [D3] = "=INT((RAND()*9)+1)"
    [e3] = "=INT((RAND()*9)+1)"
    [F3] = "=INT((RAND()*9)+1)"
End Sub

1-10 arasında benzersiz sayı üretir. 10 sayının 10'u da farklıdır.
A1'den başlayarak sırayla tek tek üretir.
Her denemede hücreleri boşaltmanız gerekmektedir.

Sub RASTGELE_SAYI()
    SÜTUN = [IV1].End(1).Column
    If SÜTUN = 10 Then Exit Sub
BAŞLA:
    sayi = Int((10 * Rnd) + 1)
    If WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(1, SÜTUN + 1)), sayi) > 0 Or sayi = 0 Then GoTo BAŞLA
    If Cells(1, SÜTUN) <> "" Then
    Cells(1, SÜTUN + 1) = sayi
    Else
    Cells(1, SÜTUN) = sayi
    End If
End Sub

A sütununa son sınırı 60 olmak üzere 30 tane farklı sayı üretir.

Sub sayi_uret()
Randomize
    While i <= 29
        sayi = Int(Rnd(59) * 60 + 1)
        If WorksheetFunction.CountIf([a1:a30], sayi) = 0 Then
            i = i + 1
            Cells(i, 1) = sayi
        End If
    Wend
End Sub

A1 hücresine 1-100 arasında rastgele sayı üretir.

Sub sayi()
[a1] = Int(Rnd * 100)
End Sub

5 sütun ve 5 satırda yan yana ve alt alta aynı sayılar denk gelmeyecek şekilde rastgele sayı üretir.

Sub random() 'Aynı sayı denk gelmez. 5 sütunda birden üretir. Satır sütun hiçbiri çakışmaz.
For i = 1 To 5
For y = 1 To 5
10 bul = Int(Rnd * 12) + 1
If WorksheetFunction.CountIf(Columns(y), bul) > 0 Then GoTo 10
If WorksheetFunction.CountIf(Rows(i), bul) > 0 Then GoTo 10
Cells(i, y) = bul
Next: Next
End Sub

10 satırda birbirinden farklı 10 sayı üretir.

Sub benzersiz_rastgele()
Dim arr() As Long
Min = "1" 'minimum değer
Max = "10" 'maksimum değer
ReDim arr(Max - Min)
say = 0
For i = Min To Max
arr(say) = i
say = say + 1
Next

For j = 0 To UBound(arr)
x = Int(((Max - Min) * Rnd))
temp = arr(x)
arr(x) = arr(j)
arr(j) = temp
Next j
For i = 0 To UBound(arr)
Cells(i + 1, 1) = arr(i)
Next

1-9 arasında rastgele sayı üretir.

Sub Benzersiz()
10 sayi = Int(Rnd * 10)
If sayi < 1 Or sayi = [a1] Then GoTo 10
[a1] = sayi
End Sub

4 basamaklı rastgele sayı üretir.

Sub BasamakFarklı()
10 say1 = Int(Rnd * 10)
If say1 = 0 Then GoTo 10
20 say2 = Int(Rnd * 10)
If say2 = say1 Then GoTo 20
30 say3 = Int(Rnd * 10)
If say3 = say1 Or say3 = say2 Then GoTo 30
40 say4 = Int(Rnd * 10)
If say4 = say1 Or say4 = say2 Or say4 = say3 Then GoTo 40
[a1] = say1 & say2 & say3 & say4
End Sub

Kodlarda kayıtlı isimleri rastgele seçip A1 hücresine yazar.

Sub İsimSeç()
deg = Array("osman", "ali", "haluk", "levent", "sinan", "ayşe", "fatma", "caner", "cafer", "cengiz")
[a1] = deg(Int(Rnd() * 10))
End Sub

A sütunundaki isimlerden rastgele seçer; C1'e yazar.

Sub MetinSeç()
For i = 1 To 10
Cells(i, 3) = Cells(Int(Rnd() * 10) + 1, "A")
Exit Sub
Next
End Sub

Hücredeki kelimelerin yerlerini rastgele değiştirir.

Sub siradegistir()
20 deg = Split([a1], " ")
metin = ""
say = WorksheetFunction.CountA([a:a])
If say = WorksheetFunction.Fact(UBound(deg) + 1) Then
MsgBox "Tüm ihtimaller çıkmıştır."
Exit Sub
End If
For a = 1 To UBound(deg) + 1
10 sayi = Int(Rnd * (UBound(deg) + 1))
If InStr(metin, deg(sayi)) > 0 Then GoTo 10
metin = metin & " " & deg(sayi)
Next
If WorksheetFunction.CountIf([a:a], LTrim(metin)) > 0 Then GoTo 20
Range("a65536").End(3).Offset(1, 0) = LTrim(metin)
End Sub

Kaynak: excel.web.tr
İlerleyen zamanlarda yeni randomize kodlar ekleyeceğim.
Yazılı kodların örnekleri ekli dosyada mevcuttur. Her kod kendi sayfasına yazılmıştır.

 

[Taruz]

Merhaba..

Paylaşımlarınız için teşekkür ederim. Çok güzel gerçekten.

Rastgele sayı ile ilgili geçen forumda güzel bir soruya denk gelmiştim. Makro forumundaydı yanılmıyorsam..

Sayın leumruk'un sorularına ilave olabileceğini düşünüyorum..

Soru :

Rastgele 50 satır sayı üretelim ama ondalıklı. Bunlar 4 ile -4 arasında ve benzersiz olsun. Toplamıda 30 olsun..

Güzel soru bence.. Tabii taktir sizin yinede.

 

[Ferhat Pazarçevirdi]

Merhaba..

Paylaşımlarınız için teşekkür ederim. Çok güzel gerçekten.

Rastgele sayı ile ilgili geçen forumda güzel bir soruya denk gelmiştim. Makro forumundaydı yanılmıyorsam..

Sayın leumruk'un sorularına ilave olabileceğini düşünüyorum..

Soru :

Rastgele 50 satır sayı üretelim ama ondalıklı. Bunlar 4 ile -4 arasında ve benzersiz olsun. Toplamıda 30 olsun..

Güzel soru bence.. Tabii taktir sizin yinede.

Sn.Taruz

Bu fırtına değil, resmen kasırga olmuş

Hem 50 tane olacak, hem pozitif veya negatif olacak, üstüne üstlük toplamları +30 olacak ... Vallahi, Mars bile bundan daha ağır koşullarda oluşmamıştır ... Sonucu veren sayıları bulma ihtimali de -bizim PC'lerde- sanırım, evrim süresini aşar

Sevgiler ...

 

[Taruz]

Evet sanırım biraz! ağır olmuş Ferhat Bey. Şimdi sevgili beab05'in ilgili konuda yazdığı algoritmasını da okuyunca olayın olasılığı konusunda iyice ikna oldum.

İyi geceler. :hey:

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kod ile;

(-4) ve (4) değerleri arasında
Benzersiz
Ondalıklı
Toplamı 30 olan
50 adet sayı üretebilirsiniz.

Option Explicit
 
Sub EKSİDÖRT_İLE_ARTIDÖRT_ARASINDA_BENZERSİZ_SAYI_ÜRET()
    Dim Eksi_Değer As Integer, Artı_Değer As Integer
    Dim Sayı As Double, Toplam As Double, Satır As Long
    Dim En_Büyük As Double, Fark As Double, Yeni_Sayı As Double
    Dim İlk As Date, Son As Date, Süre As Date
 
    İlk = Time
    Eksi_Değer = -3
    Artı_Değer = 3
Başla:
 
    Columns(1).ClearContents
 
    Satır = 1
 
    Toplam = 0
 
    Do While Satır <= 50
Devam:
    Sayı = Evaluate("=RASTGELEARADA(" & Eksi_Değer & "," & Artı_Değer & ")+ROUND(RAND(),2)")
        If Sayı <> 0 Then
            If WorksheetFunction.CountIf([A:A], Sayı) = 0 Then
                Toplam = Toplam + Sayı
                    If Toplam <= 30 Then
                        Cells(Satır, 1) = Sayı
                        Satır = Satır + 1
                    Else
                        Toplam = Toplam - Abs(Sayı)
                        GoTo Devam
                    End If
            End If
        End If
    Loop
 
    Fark = Round(30 - WorksheetFunction.Sum(Columns(1)), 2)
    En_Büyük = WorksheetFunction.Large(Columns(1), 5)
 
    If WorksheetFunction.Sum(Columns(1)) >= 27 And WorksheetFunction.Sum(Columns(1)) < 30 Then
    Yeni_Sayı = En_Büyük + Abs(Fark)
 
    If Yeni_Sayı > (Artı_Değer + 1) Then GoTo Başla
 
    If WorksheetFunction.CountIf([A:A], Yeni_Sayı) = 0 Then
        Cells([A:A].Find(En_Büyük).Row, 1) = Yeni_Sayı
    End If
 
    ElseIf WorksheetFunction.Sum(Columns(1)) > 30 And WorksheetFunction.Sum(Columns(1)) <= 33 Then
        Yeni_Sayı = En_Büyük - Abs(Fark)
            If WorksheetFunction.CountIf([A:A], Yeni_Sayı) = 0 Then
            If Yeni_Sayı < (Eksi_Değer - 1) Then GoTo Başla
            Cells([A:A].Find(En_Büyük).Row, 1) = Yeni_Sayı
            End If
    Else
    GoTo Başla
    End If
 
    Son = Time
    Süre = Format((Son - İlk), "hh:mm:ss")
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & "İşlem süresi ; " & Süre, vbInformation
End Sub

Uygulamalı örnek dosya ektedir.

 

[leumruk]

Sayı = Evaluate("=RASTGELEARADA(" & Eksi_Değer & "," & Artı_Değer & ")+ROUND(RAND(),2)")

Syn. Hocam,
Bu satırda hata veriyor.

 

[Ferhat Pazarçevirdi]

Korhan bey,

Benim anladığım şekliyle; rastgelelik bu değil ...

Kodunuz üzerinde şunlar kafama takıldı ... Soruları kod üzerinde kırmızı ile gösterdim.

[COLOR=darkgreen]    'Satır 50'den küçük ve eşit olduğu müddetçe[/COLOR]
    Do While Satır <= 50
Devam:
    
[COLOR=darkgreen]    'Sayıyı üret ...[/COLOR]
    Sayı = Evaluate("=RASTGELEARADA(" & Eksi_Değer & "," & Artı_Değer & ")+ROUND(RAND(),2)")
        
        [COLOR=darkgreen]'Sayı 0'dan farklıysa[/COLOR] [COLOR=red][B]('Bu kısıma neden 0 dahil edilmiyor ?)
[/B][/COLOR][COLOR=red]        If Sayı <> 0 Then[/COLOR]
[COLOR=darkgreen]            'Üretilen sayı tek(yegane) ise[/COLOR]
            If WorksheetFunction.CountIf([A:A], Sayı) = 0 Then
[COLOR=darkgreen]                'Sayıyı toplama dahil et[/COLOR]
                Toplam = Toplam + Sayı
[COLOR=darkgreen]                    'Eğer toplam 30'dan küçük ve eşitse[/COLOR]
                    If Toplam <= 30 Then
[COLOR=darkgreen]                        'Hücreye sayıyı yaz[/COLOR]
                        Cells(Satır, 1) = Sayı
[COLOR=darkgreen]                        'Satırı 1 artır[/COLOR]
                        Satır = Satır + 1
[COLOR=darkgreen]                    'Eğer toplam 30'dan büyükse[/COLOR]
                    Else
[COLOR=darkgreen]                        'Toplamdan üretilen sayıyı çıkar[/COLOR]
[COLOR=red]                        Toplam = Toplam - Sayı[/COLOR]
[COLOR=darkgreen][B][COLOR=#ff0000]                        '----Burada, üretilen sayı negatifse, toplam artmıyor mu?
                        '----Toplam artınca, bundan sonra üretilecek sayılar,[/COLOR][/B][COLOR=#000000] [/COLOR][B][COLOR=red]bu durumda etkilenecektir[/B][/COLOR]
[/COLOR][COLOR=darkgreen]                        'Sayı üretmeye devam et[/COLOR]
                        GoTo Devam
                    End If
            End If
        End If
    
    Loop

Ayrıca; En_Büyük adlı değişken, neden sütundaki 5.Enbüyük değer? ... Bunun bir anlamı var mı?

Ben ise; 50 adet gerçekten rassal üretilmiş, -4 ila +4 arasında değişen sayı bulunup, toplamlarının 30 olması şeklinde düşündüm. Hiçbir kısıt koymadım.

Sizden önce yaptığım yorum, saf rassallıktan ibarettir ve süresi konusunda asla emin olunamaz.

 

[hsayar]

Değerli Arkadaşlar,
Malum bu konuda pek çok soru geliyor. Benim bir önerim olacak, bu başlık altında bu konuyla ilgili kodları ekleyebilir miyiz? Alternatifler bir başlık altında toplanırsa hangisini kullanacağımıza daha iyi karar verebiliriz.
Ben bu konuyla ilgili gelen ve gelebilecek soruları sıralamaya çalışayım:
1. A1 hücresine 1-100 arasında rastgele sayı üretme.
2. A1 hücresine 1-100 arasında rastgele sayı üretme. 100 sayı tekrarlanana kadar aynı sayı yeniden gelmeyecek. Bittiğinde çekilişin bittiği uyarısını verecek.
3. A1-A100 arası tekrarsız rastgele sayı üretme.
4. A1:A50 arasında yazılı rastgele sayıları B1:B50 arasına rastgele sıralama.
5. A1:A50 arasındaki hücrelerden birini rastgele seçme.
6. A1:A50 arasındaki hücreleri rastgele seçme, seçtiğini bir daha seçmeme.

Şu an aklıma gelenler bunlar, elinde veri olan arkadaşlar paylaşırsa memnun olurum.
Burada olmayıp da aklınıza gelen konuyla ilgili bildiklerinizi de paylaşırsanız, sevinirim.
katkısı olacak arkadaşlara şimdiden teşekkürler.

Korhan Hocam,
Teşekkür ederim. Çok güzel bir kaynak oldu.
Bir kaç tane daha aklıma konu geldi:
1. A1: A10 arasındaki hücrelerde bulunan verileri kendi içinde rastgele karıştırma.
2. Aynı şekilde yan yana bulunan birden fazla sütunda bulunan verileri dağılım düzeni birbiriyle aynı olmayacak şekilde rastgele dağıtma.
Syn. Hocam bunlarında çözümü var mı?
Bunların dışında aklınıza gelen başka rastgele dağılım biçimleri varsa, eklerseniz sevinirim.
Saygılar...

kodlar

'1. A1 hücresine 1-100 arasında rastgele sayı üretme.
'2. A1 hücresine 1-100 arasında rastgele sayı üretme. 100 sayı tekrarlanana kadar aynı sayı yeniden gelmeyecek. Bittiğinde çekilişin bittiği uyarısını verecek.
'3. A1-A100 arası tekrarsız rastgele sayı üretme.
'4. A1:A50 arasında yazılı rastgele sayıları B1:B50 arasına rastgele sıralama.
'5. A1:A50 arasındaki hücrelerden birini rastgele seçme.
'6. A1:A50 arasındaki hücreleri rastgele seçme, seçtiğini bir daha seçmeme.
'Korhan Hocam,
'Teşekkür ederim. Çok güzel bir kaynak oldu.
'Bir kaç tane daha aklıma konu geldi:
'1. A1: A10 arasındaki hücrelerde bulunan verileri kendi içinde rastgele karıştırma.
'2. Aynı şekilde yan yana bulunan birden fazla sütunda bulunan verileri dağılım düzeni birbiriyle aynı olmayacak şekilde rastgele dağıtma.
'

Sub Soru1()
  data = BenzersizRastgeleSayilar(1, 1, 100, enCevapHayır)
  Cells(1, 1) = data(1)
End Sub

Sub Soru3()
  data = BenzersizRastgeleSayilar(100, 1, 100, enCevapHayır)
  For i = 1 To UBound(data)
    Cells(i, 1) = data(i)
  Next i
End Sub

Sub soru4()
Dim Csf As Excel.Worksheet:     Set Csf = ActiveSheet
Dim rngGiris As Range, rngcikis As Range
With Csf
  Set rngGiris = .Range(.Cells(1, 1), .Cells(50, 1))
  Set rngcikis = .Range(.Cells(1, 2), .Cells(50, 2))
  Call PrSubSütunlarıKarıştır(rngGiris, rngcikis)
End With
Set Csf = Nothing
Set rngGiris = Nothing
Set rngcikis = Nothing
End Sub

Sub soru5()
Dim Csf As Excel.Worksheet:     Set Csf = ActiveSheet
With Csf
  data = BenzersizRastgeleSayilar(1, 1, 50, enCevapHayır)
  MsgBox .Cells(data(1), 1).Address & vbNewLine & "Hücresi seçildi.", vbInformation
  .Cells(data(1), 1).Select
End With
Set Csf = Nothing
End Sub
Sub soru_ek1()
Dim Csf As Excel.Worksheet:     Set Csf = ActiveSheet
Dim rngGiris As Range
With Csf
  Set rngGiris = .Range(.Cells(1, 1), .Cells(50, 1))
  Call PrSubSütunlarıKarıştır(rngGiris, rngGiris)
End With
Set Csf = Nothing
Set rngGiris = Nothing
Set rngcikis = Nothing
End Sub

fonksiyonlar

Public Enum enCevap
  enCevapEvet
  enCevapHayır
End Enum
Function BenzersizRastgeleSayilar(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long, Optional Sıralımı As enCevap) As Variant
'Benzersiz Rastgele Sayılar Üretir.
'Kullanımı Aşağıdaki gibidir
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
BenzersizRastgeleSayilar = False

If KacAdetSayi < 1 Then Exit Function
If EnKucukSayi > EnBuyukSayi Then Exit Function
If KacAdetSayi > (EnBuyukSayi - EnKucukSayi + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (EnBuyukSayi - EnKucukSayi) + EnKucukSayi)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = KacAdetSayi

ReDim varTemp(1 To KacAdetSayi)

For i = 1 To KacAdetSayi
varTemp(i) = RandColl(i)
Next i
Set RandColl = Nothing

If Sıralımı = enCevapEvet Then
  '**************ripek********************
  For i = 1 To KacAdetSayi - 1
      For j = i + 1 To KacAdetSayi
          If varTemp(i) > varTemp(j) Then
              k = varTemp(i)
              varTemp(i) = varTemp(j)
              varTemp(j) = k
          End If
      Next j
  Next i
  '**************ripek********************
End If
BenzersizRastgeleSayilar = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function
Sub PrSubSütunlarıKarıştır(rngGiris As Range, rngcikis As Range)
Dim data As Variant
Dim snlTab() As Variant
Dim tabSnc() As Variant
Dim ii As Long, sat As Long
snlTab = rngGiris
'\\ Karıştırılacak verilerin index nolarını alıyoruz.
  data = BenzersizRastgeleSayilar(UBound(snlTab), LBound(snlTab), UBound(snlTab), enCevapHayır)
  If TypeName(data) = "Boolean" Then
    MsgBox "BenzersizRastgeleSayilar fonksiyonu için verdiğiniz KacAdetSayi, EnKucukSayi, EnBuyukSayi değerlerinden bir veya daha fazlası uyumsuzdur."
    Exit Sub
  End If
'\\ Elemanları İndex numaralarından tabSnc Dizisine atıyoruz.
    ii = 0
    For sat = LBound(snlTab) To UBound(snlTab)
      ii = ii + 1
      ReDim Preserve tabSnc(1 To 1, 1 To ii)
      tabSnc(1, ii) = snlTab(data(sat), 1)
    Next sat
'\\ tabSnc Dizisini Çalışma sayfasına geri veriyoruz.
    rngcikis = Empty
    rngcikis = Application.Transpose(tabSnc)
'\\ Değişknelerimizi siliyoruz.
Erase snlTab, tabSnc, data
Set rngGiris = Nothing
Set rngcikis = Nothing
End Sub

 

[Muhammet Okumuş]

korhan ayhan hocam 3.sorunun cevbı için a1:a100 arasına tekrarsız 100 sayı üretmişsiniz.peki bunu mause her bastığımızda 1 rakam seçmesini yapabilirmisiniz.

 

[hsayar]

eğer çekilişlerimde aynı rakamlar gelebilir diyorsanız aşağıdaki kodları kullanmalısınız:
module

Sub Soru3a()

    data = RastgeleRakamlar(100, 1, 100)
  For i = 1 To UBound(data)
    Cells(i, 1) = data(i)
  Next i
End Sub

Fonksiyonlara ek

Function RastgeleRakamlar(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long) As Variant
'Benzersiz Rastgele Sayılar Üretir.
'// KacAdetSayi   : KaçAdet Sayı Üretilecek
'// EnKüçükSayi   : Alt Sınırımız var ise kaç
'// EnBüyükSayi   : Üst Sınırımız var ise kaç
'// Data = BenzersizRakamlar(5, 20, 100)    ' 20 ila 100 arasında 5 adet sayı üret.

Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
RastgeleRakamlar = False
  
If KacAdetSayi < 1 Then Exit Function
If EnKucukSayi > EnBuyukSayi Then Exit Function
If KacAdetSayi > (EnBuyukSayi - EnKucukSayi + 1) Then Exit Function

Set RandColl = New Collection
Randomize
Do
  i = CLng(Rnd * (EnBuyukSayi - EnKucukSayi) + EnKucukSayi)
  RandColl.Add i
Loop Until RandColl.Count = KacAdetSayi

ReDim varTemp(1 To KacAdetSayi)
For i = 1 To KacAdetSayi
  varTemp(i) = RandColl(i)
Next i
Set RandColl = Nothing
RastgeleRakamlar = varTemp
Erase varTemp
k = 0: i = 0: j = 0
End Function

 

[leumruk]

Syn. hsayar,
Teşekkürler. Kodlar muhteşem...Ellerinize sağlık. Devamını bekliyoruz.

 

[Korhan Ayhan]

Selamlar,

Ferhat bey,

Sıfır sayısının toplama etkisi olmayacağından dolayı üretilen sayıların sıfırdan farklı olması gerektiğini düşündüm.

Toplam=Toplam-Sayı ifadesinde üretilen sayı negatifse toplam artacaktır. Doğru bir tesbitte bulunmuşsunuz. (Bu kısmı düzeltip dosyayı revize ederim.)

En_Büyük adlı değişkende 5 değerini Fark ile tesbit edilen değeri bu değişkene eklediğimde (4) değerinden büyük olmaması için eklemiştim. Amacım kodu biraz daha hızlandırmaktı.

Tabiki istenilen şartlarda rastgele üretilen sayılarda verilen toplama ulaşmak için sizinde belirttiğiniz gibi süreyi bilmek imkansızdır.

Amacım sadece çözüm üretip beyin fırtınasına katkıda bulunmaktı.

 

[Korhan Ayhan]

Selamlar,

Sn. leumruk,

Hatayı gidermek için aşağıdaki işlemleri yapınız.

ARAÇLAR - EKLENTİLER menüsünden ToolPak - VBA Çözümleyicisi seçeneğini aktif hale getirin.