tek butonla sütunlarda rastgele sayı üretmek

[Muhammet Okumuş]

tek butonla sütunlarda rastgele sayı üretmek

 

[hsayar]

http://www.excel.web.tr/showthread.php?t=58002
inceleyiniz...

 

[Muhammet Okumuş]

yapılması gereken yedi butunu tek butona bağlamak

 

[leumruk]

yapılması gereken yedi butunu tek butona bağlamak

Butonları değil ama kodları biribirine bağladım. Pratik bir çözüm. Dosyayı inceleyiniz.

 

[Muhammet Okumuş]

ama ben sütunlarda tek tek istiyorum.bir kez bastığımızda önce b, sonra bastığımda c, d .e bu şekilde olacak

 

[Muhammet Okumuş]

çözüm war mı

 

[leumruk]

çözüm war mı

Kodları A20 hücresi şartına bağladım. Hücre boşsa 1. makro, 1'se 2. makro, 2'yse 3. makra çalışıyor. Bu şekilde sona kadar gidiyor. İstediğin gibi her tıklamada ayrı bir kod çalışıyor.

 

[hsayar]

sn mutlu okumuş benim anladığı
sütunlara gelecek sayıların birbirine eşit olabileceği ve rastgele sıralı olacağı yönünde. buna göre kodlar aşağıdaki fonksiyondan yararlanarak düzenlenebilir.

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
'*****www.excel.wTr***********
End Function

Sub Test()
Data = RastgeleRakamlar(5, 20, 100)
For i = 1 To 5
  msj = msj & Data(i) & vbNewLine
Next i
MsgBox msj
End Sub

 

[Muhammet Okumuş]

iki tane kod yazmışsın.bunları nasıl kullanacağım.nereye yapıştıracağım.neden iki tane ayrı ayrı yazdınız.makro hakkında biraz bilgi verebilirmisiniz

 

[veyselemre]

Sub sayiUretim()
    Dim a() As Integer
    For x = 2 To 8
        If Cells(1, x) = "" Then sut = x: Exit For
    Next x

    If sut = "" Then
        MsgBox "Bütün Sütunlar Dolduğu İçin Temizleme Butonuna Basın Yeniden Deneyin"
        Exit Sub
    End If

    Columns(sut).ClearContents

    ReDim a(1 To [a1]) As Integer
    For x = 1 To [a1]: a(x) = x: Next x
    Randomize Timer

    For tekrar = 1 To 3 'Dizi elemanları arasında 3 kez yer değiştirme yapılıyor.
        For x = 1 To [a1]
            y = Int([a1].Value * Rnd + 1)
            tmp = a(x)
            a(x) = a(y)
            a(y) = tmp
        Next x
    Next tekrar

    For x = 1 To [a2]
        Cells(x, sut) = a(x)
    Next x
    Erase a
    MsgBox "İstediğiniz Yerleştirme İşlemi [" & Chr(sut + 64) & "] Sütununa Yapıldı."
End Sub

 

[leumruk]

Syn. muokumuş,
7 nolu msjdaki dosyayı deneyin. İstediğiniz gibi her tıklamada bir sütun doluyor.

 

[Muhammet Okumuş]

debug diye hata verdi

 

[Muhammet Okumuş]

leumrruk şimdi olmuş.veyselemernin kodalrı debug diye uyarı veriyor

 

[leumruk]

leumrruk şimdi olmuş.veyselemernin kodalrı debug diye uyarı veriyor

Syn. muokumuş,
Aşağıda Veysel Bey'in kodlarının bulunduğu dosya var. Gayet güzel çalışıyor. Kopyalarken bir hata yapmış olmalısınız.
Bunu kullanmanızı tavsiye ederim. Bütün işi tek kodda halletmiş.

 

[Muhammet Okumuş]

Evet bu kez olmuş.teşekkür ederim.ama uyarı olmasaydı daha güzel olurdu

 

[leumruk]

Evet bu kez olmuş.teşekkür ederim.ama uyarı olmasaydı daha güzel olurdu

Dosyadaki mesajı kaldırdım, dosyayı tekrar indirip yeniden deneyebilirsiniz.
Bu benim içinde güzel bir kaynak oldu.
Syn. Veyselemre'ye paylaşımından dolayı teşekkür ederim.

 

[hsayar]

Sub SayıÜret()
Dim CSf As Worksheet:                         Set CSf = ThisWorkbook.Sheets("Sayfa1")
Dim data As Variant, KaçAdet As Long, EnKüçük As Long, EnBüyük As Long
Dim İlkSütun, SonSütun, BoşSütun
Dim sütunNo As Integer

With CSf
  If .Cells(6, "B") = "" Then .Cells(6, "B") = .Cells(4, "B")
  KaçAdet = .Cells(1, "B")
  EnKüçük = .Cells(2, "B")
  EnBüyük = .Cells(3, "B")

    
  
  If .Cells(4, "B") >= .Cells(6, "B") Or .Cells(6, "B") <= .Cells(5, "B") Then
    data = RastgeleRakamlar(KaçAdet, EnKüçük, EnBüyük)
    [COLOR=Red][B]If VarType(data) = vbBoolean Then Exit Sub[/B][/COLOR]
    For i = 1 To KaçAdet
      .Cells(i, .Cells(6, "B")) = data(i)
    Next i
    Erase data
    .Cells(6, "B") = .Cells(6, "B") + 1
  Else
    MsgBox "En fazla " & .Cells(5, "B") & " Sütuna kadar değer atanabilir. Son sütun noyu değiştiriniz"
  End If
End With
Set CSf = Nothing
End Sub
Sub Temizle()
Dim CSf As Worksheet:                         Set CSf = ThisWorkbook.Sheets("Sayfa1")
With CSf
   .Range(.Cells(1, 3), .Cells(52, .Cells(2, 256).End(xlToLeft).Column)) = Empty
   .Cells(6, "B") = Empty
End With
Set CSf = Nothing
End Sub


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

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
'*****www.excel.wTr***********
End Function

en büyük sayı en küçük sayıdan küçük girilince debug hatası almamak için kod eklendi.