• DİKKAT

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

rastgele sayılar(toto)

bir birine eşit olan sütunlar hepsi olmasa da bi kaçtane birbirine eşit sütun çıkıyor
 
sn ahmet yarın ilk işim toto nasıl oynanır onu öğrenmek ondan sonra çözüm üretmeye çalışırım... yada siz olmamasını istediğiniz halini oluşturup, örnek dosya olarak eklerseniz yardımcı olmaya çalışırım.
 
sn sayar
sayıları dağıttığımızda mesela k2:k16 ile t2:t16 sütunları bir birinin aynısı oluyor. sütun olarak değerlendirme yapıyoruz ve 100 ayrı kombinasyon oluşturmalıyız. 100 kolon oynadığımız zaman kolonlardan eşit olan olursa aynı kolonu birden fazla oynamış oluruzki o da şansımızı azaltır. bilmem anlatabildim mi? yani alt alta gelen sayılar bir kolon oluşturuyor. dosyanın oluşmuş hali bu. yapacağımız kolonları konrol ettirecek bir makro eklemek. teşekkürler
 
anladım gibi sn ahmet.... kontrol ettik ve h, g, k, da sütunlarının eşit olduğunu tespit ettik ne olacak?

benim yapabileceğim bir iş mi ondan da emin değilim...aklıma yöntem geliyor desem yalan söylemiş olurum. bu akşam düşüneyim tespit edebilirmiyim kodlarla.
 
bu sütunları aynı mı kabul ediyorsunuz?
2 2
1 1
1 1
1 0
1 1
0 2
0 2
0 1
1 1
1 1
1 2
2 0
1 1
2 1
2 0
ikisinde de 8 adet 1 , 3adet 0 , 4 adet 2 var yoksa aynı sırada olunca mı aynı kabul ediyorsunuz; yani aşağıdaki gibi

2 2
1 1
1 1
1 1
1 1
0 0
0 0
0 0
1 1
1 1
1 1
2 2
1 1
2 2
2 2
 
Aynı sırada olduğu zaman kolonları aynı kabul ediyoruz.
Buna bir çözüm yolu olarak benim aklıma şu geliyor, her satırın transpozunu alıyoruz yani yataya çeviriyoruz ve rakamları yan yana dizip bir sayı elde ediyoruz, böylece her sütunun bir değeri oluyor, biz bu değerleri karşılaştırarak bunların eşit olup olmadıklarını bulabiliriz, sayı olarak karşılaştırmak kolay farkını alırız 0 ise aynıdır, metin olarak da yapabiliriz vba da var mı bilmiyorum ama excelin kendi fonksiyonları arasında "özdeş" fonksiyonu ile yapılabilir.
 
janveljan' Alıntı:
Aynı sırada olduğu zaman kolonları aynı kabul ediyoruz.
Buna bir çözüm yolu olarak benim aklıma şu geliyor, her satırın transpozunu alıyoruz yani yataya çeviriyoruz ve rakamları yan yana dizip bir sayı elde ediyoruz, böylece her sütunun bir değeri oluyor, biz bu değerleri karşılaştırarak bunların eşit olup olmadıklarını bulabiliriz, sayı olarak karşılaştırmak kolay farkını alırız 0 ise aynıdır, metin olarak da yapabiliriz vba da var mı bilmiyorum ama excelin kendi fonksiyonları arasında "özdeş" fonksiyonu ile yapılabilir.
Genişletmek için tıkla ...

Aynı sütunları bulduğumuza zaman ne yapacağız onuda söylerseniz ona göre uğraşırım artık....
 
Onu ahmet beye sormak lazım, daha önceki notlarında farklı renkle göstersin demişti ama en son nasıl istiyor bilmiyorum.
 
ahmett46' Alıntı:
sn sayar
sayıları dağıttığımızda mesela k2:k16 ile t2:t16 sütunları bir birinin aynısı oluyor. sütun olarak değerlendirme yapıyoruz ve 100 ayrı kombinasyon oluşturmalıyız. 100 kolon oynadığımız zaman kolonlardan eşit olan olursa aynı kolonu birden fazla oynamış oluruzki o da şansımızı azaltır. bilmem anlatabildim mi? yani alt alta gelen sayılar bir kolon oluşturuyor. dosyanın oluşmuş hali bu. yapacağımız kolonları konrol ettirecek bir makro eklemek. teşekkürler
Genişletmek için tıkla ...

buyrun kodlar eklidir;

Kod: 
Option Explicit
Sub TotoKuponuKolonKonrol_Hsayar()
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII
'IIIIIIIIII]      Çalışma Sayfasının h-dc sütunlarına mükerrer girilen değerleri        [IIIIIIIIII
'IIIIIIIIII]      tespit eder Ve kırmızıya boyar.                                       [IIIIIIIIII
'\\ <<=H=>> <<=S=>> <<=A=>> <<=Y=>> <<=A=>> <<=R=>> <<=™=>>           <<=09/11/2008=>>  <<=23:50=>>
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII§
Dim Csf As Worksheet: Set Csf = Worksheets("sayfa1")
Dim arrSut1 As Variant, arrSut2 As Variant
Dim strSut1  As String, strSut2 As String
Dim stnNo1%, stnNo2%, i%

With Csf
'8-107
For stnNo1 = 8 To 107 - 1
  For stnNo2 = stnNo1 + 1 To 107
    arrSut1 = .Range(.Cells(2, stnNo1), .Cells(16, stnNo1)).Value
    arrSut2 = .Range(.Cells(2, stnNo2), .Cells(16, stnNo2)).Value
    strSut1 = "": strSut2 = ""
    
    For i = LBound(arrSut1) To UBound(arrSut1)
      strSut1 = strSut1 & arrSut1(i, 1)
    Next i
    
    For i = LBound(arrSut2) To UBound(arrSut2)
      strSut2 = strSut2 & arrSut2(i, 1)
    Next i
    Erase arrSut1, arrSut2
 
    If strSut1 = strSut2 Then
      MsgBox stnNo1 & " ve " & stnNo2 & " nolu kolonlar birbirine eşittir"
      
      With .Range(.Cells(2, stnNo1), .Cells(16, stnNo1))
        .Interior.Color = vbRed
      End With
      
      With .Range(.Cells(2, stnNo2), .Cells(16, stnNo2))
        .Interior.Color = vbRed
      End With
    End If
  Next stnNo2
Next stnNo1
End With
Set Csf = Nothing
End Sub
 
slm
aynı sütunlar bulunduğunda otomatik olarak değiştirme imkanı varsa değiştirmesini yoksa o sütunların farklı bir zemin rengi almasını istiyordum. ama zor bi iş gibi görünüyor. isterseniz uğraşmayın bu halide yeterli hocam tekrar teşekkür ediyorum
 
ahmett46' Alıntı:
slm
aynı sütunlar bulunduğunda otomatik olarak değiştirme imkanı......./quote]
Sütunlardaki değerleri değiştirmek derken yeniden TotoOYna makrosunun çalışmasını ve benzersizler çıkana kadar devam etmesini mi diyorsunuz?
Aslında olabilir ama sınırsız döngüye girme ihtimalide var...
Genişletmek için tıkla ...
 
şunu bir deneyiniz ben kontrol ettim ama sizde test ediniz;
Aktif kitaptan değilde kod modulünün çalıştığı kitaptan çalışması sağlanmış, ve hız açısından kod çalışırken ekran yenileme ve otomatik hesaplama kapatılmıştır.

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
'IIIIIIIIII]      Kolon eşitliği sağlandığında başa döner tekrar üretir.                [IIIIIIIIII
'\\ <<=H=>> <<=S=>> <<=A=>> <<=Y=>> <<=A=>> <<=R=>> <<=™=>>           <<=10/11/2008=>>  <<=09:30=>>
'IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII§

SayıÜret:
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim snlSat() As String, snlsatTemp() As String
Dim data() As Long
Dim i%, ii%, iStn%, iStr%, lngSnsNo1&, lngSnsNo0&, lngSnsNo2&
With Csf
'// Eski Değerleri temizliyoruz.
  With .Range(.Cells(2, 8), .Cells(16, 107))
    .Clear
    With .Font
      .Name = "Courier New"
      .Size = 10
      .Bold = True
      .Color = vbBlack
    End With
    .Interior.Color = vbGreen
  End With
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
  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, 4), .Cells(iStr, 6)).Select
      GoTo ProsodürSonu
    End If
'/// 2 ila 16 sütunlar arasında döngü başlattık.
    For iStn = 8 To 107
      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

Kontrol:
Dim arrSut1 As Variant, arrSut2 As Variant
Dim strSut1  As String, strSut2 As String
Dim stnNo1%, stnNo2%, msj$

With Csf
  For stnNo1 = 8 To 107 - 1
    For stnNo2 = stnNo1 + 1 To 107
      arrSut1 = .Range(.Cells(2, stnNo1), .Cells(16, stnNo1)).Value
      arrSut2 = .Range(.Cells(2, stnNo2), .Cells(16, stnNo2)).Value
      strSut1 = "": strSut2 = ""

      For i = LBound(arrSut1) To UBound(arrSut1)
        strSut1 = strSut1 & arrSut1(i, 1)
      Next i

      For i = LBound(arrSut2) To UBound(arrSut2)
        strSut2 = strSut2 & arrSut2(i, 1)
      Next i
      i = 0
      Erase arrSut1, arrSut2
      If strSut1 = strSut2 Then
        msj = stnNo1 & " ve " & stnNo2 & " nolu kolonlar birbirine eşitt olduğundan"
        msj = msj & vbNewLine & " SayıÜret başlığı yinelenecektir."
        MsgBox msj, 16, "HSAYAR"
        GoTo SayıÜret
      End If
    Next stnNo2
  Next stnNo1
MsgBox "İşleminiz tamamlandı", vbOKOnly + vbInformation, "HSAYAR"
End With
ProsodürSonu:
Set Csf = Nothing
With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
End With
End Sub

Bu fonksiyonu bizlere kazandıran Sn. Ripek'e tekrar teşekkür ederim. çok faydalı çoook.
Kod: 
Function UniqueRandomNumbers(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long) 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&
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
            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
 
Son düzenleme:
Bu Dosyayı Eski Haline Getirebilir misiniz?

Bütün dosyalar bu hale geldi düzeltip nedenini açıklar mısınız?
Dosyaların sonunda FEB yazıyor (.xls.FEB)
 

Ekli dosyalar

Son düzenleme:
kardeş bunu yaptım b ile p arası sarı oluyor sayı yok.hem ben her sütun için tek tek basmak istiyorum
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst