rastgele sayılar(toto)

ahmett46 · 7 Kasım 2008

slm arkadaşlar
formun yeniden açılışının mutluluğunu yaşıyorum. emeği geçen yönetici ve arkadaşlara teşekkür ediyorum.
ekte sunduğum dosyada koda ihtiyacım var. yardımlarınızı bekliyorum. teşekkürler

usta07 · 8 Kasım 2008

Nejdet Yeşerten Hocamız sağolsun ek dosyayı inceleyiniz işinizi göreceğine inanıyorum bol şanslar

ahmett46 · 8 Kasım 2008

usta07 öncelikle teşekkür ediyorum ama isteğimi karşılamıyor.

ahmett46 · 8 Kasım 2008

yokmu yardımcıolacak kimse

hsayar · 8 Kasım 2008

Aşağıdaki Fonksiyon ile benzersiz çekilişler yapılabilir. sayısal loto yordamında görüldüğü üzere 1 ila 49 arasında benzersiz çekliliş yap dedik. İstediğiniz farklı bir şey ise yardımcı olmak isterim.

Kod:

Sub SayısalLoto
Data = UniqueRandomNumbers(6, 1, 49)
Msgbox Data(1) & "   " & Data(2) & "   " & Data(3) & "   " & Data(4) & "   " & Data(5) & "   " & Data(6)
End sub

Kod:

Function UniqueRandomNumbers(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long) As Variant
'Function UniqueRandomNumbers(NumCount As Long, LLimit As Long, ULimit As Long) As Variant
'Benzersiz Rastgele Sayılar Üretir.
' creates an array with NumCount unique long random numbers in the range LLimit - ULimit (including)
'Kullanımı Aşağıdaki gibidir
'Bir değişkene = (
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
UniqueRandomNumbers = 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
'**************ripek********************
For i = 1 To KacAdetSayi - 1
    For j = i + 1 To KacAdetSayi
        If varTemp(i) > varTemp(j) Then
        'Switch(varTemp(i),varTemp(j))
            k = varTemp(i)
            varTemp(i) = varTemp(j)
            varTemp(j) = k
        End If
    Next j
Next i
'**************ripek********************
Set RandColl = Nothing
UniqueRandomNumbers = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function

hsayar · 8 Kasım 2008

sn ahmet ben sayısal lota anladfığım için yukardaki kodları verdim.
aşağıdaki açıklmanıza göre verdiğim size uymayacak;

YAPMAK İSTEDİĞİM ŞU BİR BUTON KOYUP TIKLADIĞIMDA S,T VE U SÜTUNLARINDAKİ SAYILAR KADAR RAKAMLARI SATIRLARA RASGELE YERLEŞTİRECEK. SÜTUNLARI KONTROL EDİP SÜTUNDAKİ SAYILAR EŞİT OLMAYACAK DAHA AÇIK BİR İFADE İLE SÜTUNLAR BİR BİRİNİN AYNISI OLMAYACAK

Ancak yukarıdaki fonksiyon ile satırlara mesala 2. satıra rastgele 8 adet 1, 5 adet 0, 2 adet 2 getirebilirm gibi geldi. Ancak sütunlarda benzersiz olsunda kararlı iseniz açıkcası beceremem.

ahmett46 · 8 Kasım 2008

sn hsayar bey önce 2. satıra rastgele o sayı adetlerini yerleştirelim. o da yeterli olacaktır. teşekkürler

ahmett46 · 9 Kasım 2008

arkadaşlar konuyla ilgilenenyok mu

hsayar · 9 Kasım 2008

sn ahmet daha yeni sabah oldu bakacağım ama garanti veremiyorum.

hsayar · 9 Kasım 2008

Sizin verdiğiniz açıklma doğrultusunda yaptıım, toto oynamadığım için denemeleriniz yapınız.

Kod:

Option Explicit
Sub hsrtotodeneme()
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII
'IIIIIIIIII]      Çalışma Sayfasının STU sütunlarına girilen değerleri baz alarak       [IIIIIIIIII
'IIIIIIIIII]      B-P Sütunlarına rastgele 1,0,2 değerlerini dağıtır.                   [IIIIIIIIII
'\\ <<=H=>> <<=S=>> <<=A=>> <<=Y=>> <<=A=>> <<=R=>> <<=™=>>           <<=09/11/2008=>>  <<=13:50=>>
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII§
Dim Csf As Worksheet: Set Csf = Worksheets("sayfa1")
Dim snlSat() As String, snlsatTemp() As String
Dim data As Variant
Dim i%, ii%, iStn%, iStr%, lngSnsNo1&, lngSnsNo0&, lngSnsNo2&
With Csf
'// Eski Değerleri temizliyoruz.
  With .Range(.Cells(2, 2), .Cells(16, 16))
    .Clear
    .Font.Bold = True
    .Font.Color = vbBlue
    .Interior.Color = vbYellow
  End With
'// 2 ila 16 satırlar arasında döngü başlattık.
  For iStr = 2 To 16
    lngSnsNo1 = .Cells(iStr, 19)  'kaç adet 1 yerleşeceğini öğrendik.
    lngSnsNo0 = .Cells(iStr, 20)  'kaç adet 0 yerleşeceğini öğrendik.
    lngSnsNo2 = .Cells(iStr, 21)  'kaç adet 2 yerleşeceğini öğrendik.
'/// 2 ila 16 sütunlar arasında döngü başlattık.
    For iStn = 2 To 16
      i = i + 1
      ReDim Preserve snlSat(1 To i)
      snlSat(i) = .Cells(iStr, iStn).Address   ' ve Adreslieri diziye aldık.
    Next iStn
'/// 1 şans numarası olarak oynanmışsa
    If lngSnsNo1 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo1, 1, UBound(snlSat))  'kaçadet1 yerleşecek, başlangıç no, bitiş no
      For i = 1 To lngSnsNo1                'yerleştime işlemine başladık.
        .Range(snlSat(data(i))).Value = 1   'kura sonucu belirlenen numara sanal satırımızdaki ahngi adrese karşılık geliyorsa ona yazıyoruz.
        snlSat(data(i)) = Empty             'tekrar kullanmamak içöini boşaltıyoruz.
      Next i
      For i = LBound(snlSat) To UBound(snlSat)  'Kullandıklarımızı diziden çıkartıp geçici diziye alacağzı, sonra gerçek dizimize geri vereceğiz.
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      snlSat = snlsatTemp
      Erase snlsatTemp(), data: ii = 0
    End If
'/// 0 şans numarası olarak oynanmışsa
    If lngSnsNo0 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo0, 1, UBound(snlSat))
      For i = 1 To lngSnsNo0
        .Range(snlSat(data(i))).Value = 0
        snlSat(data(i)) = Empty
      Next i
      For i = LBound(snlSat) To UBound(snlSat)
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      snlSat = snlsatTemp
      Erase snlsatTemp(), data: ii = 0
    End If
'/// 2 şans numarası olarak oynanmışsa
    If lngSnsNo2 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo2, 1, UBound(snlSat))
      For i = 1 To lngSnsNo2
        .Range(snlSat(data(i))).Value = 2
        snlSat(data(i)) = Empty
      Next i
      For i = LBound(snlSat) To UBound(snlSat)
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      snlSat = snlsatTemp
      Erase snlsatTemp(), data: ii = 0
    End If
    Erase snlSat()
    i = 0
'diğer satırı dolduracağız.
  Next iStr
End With
Set Csf = Nothing
End Sub

Function UniqueRandomNumbers(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long) As Variant
'Function UniqueRandomNumbers(NumCount As Long, LLimit As Long, ULimit As Long) As Variant
'Benzersiz Rastgele Sayılar Üretir.
' creates an array with NumCount unique long random numbers in the range LLimit - ULimit (including)
'Kullanımı Aşağıdaki gibidir
'Bir değişkene = (
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
UniqueRandomNumbers = 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
'**************ripek********************
For i = 1 To KacAdetSayi - 1
    For j = i + 1 To KacAdetSayi
        If varTemp(i) > varTemp(j) Then
        'Switch(varTemp(i),varTemp(j))
            k = varTemp(i)
            varTemp(i) = varTemp(j)
            varTemp(j) = k
        End If
    Next j
Next i
'**************ripek********************
Set RandColl = Nothing
UniqueRandomNumbers = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function

ahmett46 · 9 Kasım 2008

hocam elinize emeğinize sağlık
örnek olarak vermiştim kendime uyarlayamadım bunu H2-DC16 aralığına nasıl uygularız. tekrar teşekkürler

hsayar · 9 Kasım 2008

Subu değiştiriniz yada kırmızı satırları ilave ediniz, fonksiyon kalsın;

Kod:

Sub hsrtotodeneme()
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII
'IIIIIIIIII]      Çalışma Sayfasının STU sütunlarına girilen değerleri baz alarak       [IIIIIIIIII
'IIIIIIIIII]      B-P Sütunlarına rastgele 1,0,2 değerlerini dağıtır.                   [IIIIIIIIII
'\\ <<=H=>> <<=S=>> <<=A=>> <<=Y=>> <<=A=>> <<=R=>> <<=™=>>           <<=09/11/2008=>>  <<=13:50=>>
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII§
Dim Csf As Worksheet: Set Csf = Worksheets("sayfa1")
Dim snlSat() As String, snlsatTemp() As String
Dim data As Variant
Dim i%, ii%, iStn%, iStr%, lngSnsNo1&, lngSnsNo0&, lngSnsNo2&
With Csf
'// Eski Değerleri temizliyoruz.
  With .Range(.Cells(2, 2), .Cells(16, 16))
    .Clear
    .Font.Bold = True
    .Font.Color = vbBlue
    .Interior.Color = vbYellow
  End With
'// 2 ila 16 satırlar arasında döngü başlattık.
  For iStr = 2 To 16
    lngSnsNo1 = .Cells(iStr, 19)  'kaç adet 1 yerleşeceğini öğrendik.
    lngSnsNo0 = .Cells(iStr, 20)  'kaç adet 0 yerleşeceğini öğrendik.
    lngSnsNo2 = .Cells(iStr, 21)  'kaç adet 2 yerleşeceğini öğrendik.
[B][COLOR=Red]    If (lngSnsNo1 + lngSnsNo0 + lngSnsNo2) <> 15 Then
      MsgBox "Değerler toplamı 15 olmalıdır.", 16, "DİKKAT"
      Range(.Cells(iStr, 19), .Cells(iStr, 21)).Select
      Exit Sub
    End If[/COLOR][/B]
'/// 2 ila 16 sütunlar arasında döngü başlattık.
    For iStn = 2 To 16
      i = i + 1
      ReDim Preserve snlSat(1 To i)
      snlSat(i) = .Cells(iStr, iStn).Address   ' ve Adreslieri diziye aldık.
    Next iStn
'/// 1 şans numarası olarak oynanmışsa
    If lngSnsNo1 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo1, 1, UBound(snlSat))  'kaçadet1 yerleşecek, başlangıç no, bitiş no
      For i = 1 To lngSnsNo1                'yerleştime işlemine başladık.
        .Range(snlSat(data(i))).Value = 1   'kura sonucu belirlenen numara sanal satırımızdaki ahngi adrese karşılık geliyorsa ona yazıyoruz.
        snlSat(data(i)) = Empty             'tekrar kullanmamak içöini boşaltıyoruz.
      Next i
      For i = LBound(snlSat) To UBound(snlSat)  'Kullandıklarımızı diziden çıkartıp geçici diziye alacağzı, sonra gerçek dizimize geri vereceğiz.
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      i = 0: ii = 0
      snlSat = snlsatTemp
      Erase snlsatTemp(), data
    End If
'/// 0 şans numarası olarak oynanmışsa
    If lngSnsNo0 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo0, 1, UBound(snlSat))
      For i = 1 To lngSnsNo0
        .Range(snlSat(data(i))).Value = 0
        snlSat(data(i)) = Empty
      Next i
      For i = LBound(snlSat) To UBound(snlSat)
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      i = 0: ii = 0
      snlSat = snlsatTemp
      Erase snlsatTemp(), data
    End If
'/// 2 şans numarası olarak oynanmışsa
    If lngSnsNo2 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo2, 1, UBound(snlSat))
      For i = 1 To lngSnsNo2
        .Range(snlSat(data(i))).Value = 2
        snlSat(data(i)) = Empty
      Next i
      For i = LBound(snlSat) To UBound(snlSat)
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      i = 0: ii = 0
      snlSat = snlsatTemp
      Erase snlsatTemp(), data
    End If
    Erase snlSat()
'diğer satırı dolduracağız.
  Next iStr
End With
Set Csf = Nothing
End Sub

hsayar · 9 Kasım 2008

ahmett46' Alıntı:
hocam elinize emeğinize sağlık
örnek olarak vermiştim kendime uyarlayamadım bunu H2-DC16 aralığına nasıl uygularız. tekrar teşekkürler

h2 den başlayınca v16 da bitmiyor mu? STU değerleri ne oluyor...
yada en iyisi asıl dosyayı ekleyiniz...

ahmett46 · 9 Kasım 2008

Hocam asıl dosya ekte kırmızı yazılı alana yerleştirecek S,T ve U sütunları değil D,E ve F sütunlarındaki değerler kadar rakamlar yerleşecek teşekkürler

hsayar · 9 Kasım 2008

ahmett46' Alıntı:
Hocam asıl dosya ekte kırmızı yazılı alana yerleştirecek S,T ve U sütunları değil D,E ve F sütunlarındaki değerler kadar rakamlar yerleşecek teşekkürler

buyrun Dosya eklidir.

Kod:

Option Explicit
Sub TotoKuponu_Hsayar()
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII
'IIIIIIIIII]      Çalışma Sayfasının DEF sütunlarına girilen değerleri baz alarak       [IIIIIIIIII
'IIIIIIIIII]      H-DC Sütunlarına rastgele 1,0,2 değerlerini dağıtır.                   [IIIIIIIIII
'\\ <<=H=>> <<=S=>> <<=A=>> <<=Y=>> <<=A=>> <<=R=>> <<=™=>>           <<=09/11/2008=>>  <<=13:50=>>
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII§
Dim Csf As Worksheet: Set Csf = Worksheets("sayfa1")
Dim snlSat() As String, snlsatTemp() As String
Dim data As Variant
Dim i%, ii%, iStn%, iStr%, lngSnsNo1&, lngSnsNo0&, lngSnsNo2&
With Csf
'// Eski Değerleri temizliyoruz.
  With .Range(.Cells(2,[COLOR=Red] 8[/COLOR]), .Cells(16, [COLOR=Red]107[/COLOR]))
    .Clear
    With .Font
      .Name = "Courier New"
      .Size = 10
      .Bold = True
      .Color = vbBlack
    End With
    .Interior.Color = vbGreen
  End With
'// 2 ila 16 satırlar arasında döngü başlattık.
  For iStr = 2 To 16
    lngSnsNo1 = .Cells(iStr, 4)  'kaç adet 1 yerleşeceğini öğrendik.
    lngSnsNo0 = .Cells(iStr, 5)  'kaç adet 0 yerleşeceğini öğrendik.
    lngSnsNo2 = .Cells(iStr, 6)  'kaç adet 2 yerleşeceğini öğrendik.
    If (lngSnsNo1 + lngSnsNo0 + lngSnsNo2) <> 100 Then
      MsgBox "Değerler toplamı 100 olmalıdır.", 16, "DİKKAT"
      Range(.Cells(iStr, [COLOR=Red]4[/COLOR]), .Cells(iStr, [COLOR=Red]6[/COLOR])).Select
      Exit Sub
    End If
'/// 2 ila 16 sütunlar arasında döngü başlattık.
    For iStn = [COLOR=Red]8 [/COLOR]To [COLOR=Red]107[/COLOR]
      i = i + 1
      ReDim Preserve snlSat(1 To i)
      snlSat(i) = .Cells(iStr, iStn).Address   ' ve Adreslieri diziye aldık.
    Next iStn
'/// 1 şans numarası olarak oynanmışsa
    If lngSnsNo1 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo1, 1, UBound(snlSat))  'kaçadet1 yerleşecek, başlangıç no, bitiş no
      For i = 1 To lngSnsNo1                'yerleştime işlemine başladık.
        .Range(snlSat(data(i))).Value = 1   'kura sonucu belirlenen numara sanal satırımızdaki ahngi adrese karşılık geliyorsa ona yazıyoruz.
        snlSat(data(i)) = Empty             'tekrar kullanmamak içöini boşaltıyoruz.
      Next i
      For i = LBound(snlSat) To UBound(snlSat)  'Kullandıklarımızı diziden çıkartıp geçici diziye alacağzı, sonra gerçek dizimize geri vereceğiz.
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      i = 0: ii = 0
      snlSat = snlsatTemp
      Erase snlsatTemp(), data
    End If
''    Stop
'/// 0 şans numarası olarak oynanmışsa
    If lngSnsNo0 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo0, 1, UBound(snlSat))
      For i = 1 To lngSnsNo0
        .Range(snlSat(data(i))).Value = 0
        snlSat(data(i)) = Empty
      Next i
      For i = LBound(snlSat) To UBound(snlSat)
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      i = 0: ii = 0
      snlSat = snlsatTemp
      Erase snlsatTemp(), data
    End If
'/// 2 şans numarası olarak oynanmışsa
    If lngSnsNo2 > 0 Then
      data = UniqueRandomNumbers(lngSnsNo2, 1, UBound(snlSat))
      For i = 1 To lngSnsNo2
        .Range(snlSat(data(i))).Value = 2
        snlSat(data(i)) = Empty
      Next i
      For i = LBound(snlSat) To UBound(snlSat)
        If snlSat(i) <> Empty Then
          ii = ii + 1
          ReDim Preserve snlsatTemp(1 To ii)
          snlsatTemp(ii) = snlSat(i)
        End If
      Next i
      i = 0: ii = 0
      snlSat = snlsatTemp
      Erase snlsatTemp(), data
    End If
    Erase snlSat()
'diğer satırı dolduracağız.
  Next iStr
End With
Set Csf = Nothing
End Sub
Function UniqueRandomNumbers(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long) As Variant
'Function UniqueRandomNumbers(NumCount As Long, LLimit As Long, ULimit As Long) As Variant
'Benzersiz Rastgele Sayılar Üretir.
' creates an array with NumCount unique long random numbers in the range LLimit - ULimit (including)
'Kullanımı Aşağıdaki gibidir
'Bir değişkene = (
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
UniqueRandomNumbers = 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
'**************ripek********************
For i = 1 To KacAdetSayi - 1
    For j = i + 1 To KacAdetSayi
        If varTemp(i) > varTemp(j) Then
        'Switch(varTemp(i),varTemp(j))
            k = varTemp(i)
            varTemp(i) = varTemp(j)
            varTemp(j) = k
        End If
    Next j
Next i
'**************ripek********************
Set RandColl = Nothing
UniqueRandomNumbers = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function

janveljan · 9 Kasım 2008

Satırlara yazılı olduğu kadar rastgele 0, 1 ve 2 yazdırmanın bir yolu da böyle olabilir sanırım. Yalnız bu kodlar sütunları karşılaştırmıyor.
Daha önce yazılan kodlardan sütunları karşılaştıran var mı acaba?

Kod:

Sub satyer()
Dim b(3) As Integer

For a = 2 To 16 'Aynı işlemleri ikinci satırdan 16 ncı satıra kadar tekrarlayacak

b(1) = Range("S" & a).Value 'Kaç tane 1 yerleştirileceğini alıyoruz
b(0) = Range("T" & a).Value 'Kaç tane 0 yerleştirileceğini alıyoruz
b(2) = Range("U" & a).Value 'Kaç tane 2 yerleştirileceğini alıyoruz
i = 2

Do
    sayi = Int(Rnd * 3)
    If b(sayi) > 0 Then
    Cells(a, i).Value = sayi
    b(sayi) = b(sayi) - 1
    i = i + 1
    End If
    
Loop Until i = 17

Next

End Sub

ahmett46 · 9 Kasım 2008

teşekkürler hocam tam istediğim gibi olmuş elinize sağlık

hsayar · 9 Kasım 2008

rica edeirm sn ahmet

ahmett46 · 9 Kasım 2008

Hocam çok oldun diyeceksin ama ikinci bir butonla sütunları kontrol edecek aynı sütunları farklı birrenge boyayacak mümkün mü acaba?

hsayar · 9 Kasım 2008

aynı sütunlar derken neyi kastetiğini anlamadım.

rastgele sayılar(toto)

ahmett46

Ekli dosyalar

usta07

Destek Ekibi

Ekli dosyalar

ahmett46

ahmett46

hsayar

hsayar

ahmett46

ahmett46

hsayar

hsayar

ahmett46

hsayar

hsayar

ahmett46

Ekli dosyalar

hsayar

Ekli dosyalar

janveljan

ahmett46

hsayar

ahmett46

hsayar