Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 07-11-2008, 16:48   #1
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan rastgele sayılar(toto)

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
Eklenmiş Dosyalar
Dosya Türü: rar tot.rar (5.2 KB, 318 Görüntülenme)
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 08-11-2008, 14:04   #2
usta07
Destek Ekibi
 
usta07 kullanıcısının avatarı
 
Giriş: 30/03/2008
Şehir: Antalya
Mesaj: 405
Excel Vers. ve Dili:
2003 Türkçe
Varsayılan

Nejdet Yeşerten Hocamız sağolsun ek dosyayı inceleyiniz işinizi göreceğine inanıyorum bol şanslar
Eklenmiş Dosyalar
Dosya Türü: rar Loto V01.rar (72.4 KB, 543 Görüntülenme)
__________________
Bizler, milletimizin adı olan Türk’ü, devletimizin adı olan Türkiye Cumhuriyeti’ni, vatanımızın adı olan Türkiye’mizi, milletin ve devletin simgesi bayrağımızı her şeyden çok severiz. Bizi millet yapan duygular bunlardır.
Onun için “NE MUTLU TÜRK’ÜM DİYENLERE”
usta07 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 08-11-2008, 15:02   #3
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

usta07 öncelikle teşekkür ediyorum ama isteğimi karşılamıyor.
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 08-11-2008, 18:13   #4
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

yokmu yardımcıolacak kimse
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 08-11-2008, 18:19   #5
hsayar
 
hsayar kullanıcısının avatarı
 
Giriş: 02/03/2005
Şehir: İpsala/Edirne
Mesaj: 2,968
Excel Vers. ve Dili:
ev: Ofis 2007- Win Xp iş: Ofis 2010- Win Vista
Thumbs up

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub SayısalLoto
Data = UniqueRandomNumbers(6, 1, 49)
Msgbox Data(1) & "   " & Data(2) & "   " & Data(3) & "   " & Data(4) & "   " & Data(5) & "   " & Data(6)
End sub
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
Felâket başa gelmeden evvel, onu önleyecek ve ona karşı savunulacak gerekleri düşünmek lâzımdır. Geldikten sonra dövünmenin faydası yoktur.[B]ATATÜRK[/B]

Türkler’den bahsediyorum. Düşmanına saldırırken amansız bir kasırgaya, korkunç bir denize ve insafsız bir yıldırıma benzeyen Türk; dost yanında ve silahsız düşman karşısında bir seher yelidir, berrak bir göldür. Gönül açan bu yeli yıldırmak, göz kamaştıran bu gölü coşkun bir denize çevirmek tabiatı da inciten bir gaflet olur.
[B]Tasso (İtalyan Şair)[/B]
hsayar Çevrimdışı   Alıntı Yaparak Cevapla
Eski 08-11-2008, 18:26   #6
hsayar
 
hsayar kullanıcısının avatarı
 
Giriş: 02/03/2005
Şehir: İpsala/Edirne
Mesaj: 2,968
Excel Vers. ve Dili:
ev: Ofis 2007- Win Xp iş: Ofis 2010- Win Vista
Varsayılan

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;

Alıntı:
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.
__________________
Felâket başa gelmeden evvel, onu önleyecek ve ona karşı savunulacak gerekleri düşünmek lâzımdır. Geldikten sonra dövünmenin faydası yoktur.[B]ATATÜRK[/B]

Türkler’den bahsediyorum. Düşmanına saldırırken amansız bir kasırgaya, korkunç bir denize ve insafsız bir yıldırıma benzeyen Türk; dost yanında ve silahsız düşman karşısında bir seher yelidir, berrak bir göldür. Gönül açan bu yeli yıldırmak, göz kamaştıran bu gölü coşkun bir denize çevirmek tabiatı da inciten bir gaflet olur.
[B]Tasso (İtalyan Şair)[/B]
hsayar Çevrimdışı   Alıntı Yaparak Cevapla
Eski 08-11-2008, 18:43   #7
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

sn hsayar bey önce 2. satıra rastgele o sayı adetlerini yerleştirelim. o da yeterli olacaktır. teşekkürler
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 10:49   #8
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

arkadaşlar konuyla ilgilenenyok mu
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 11:13   #9
hsayar
 
hsayar kullanıcısının avatarı
 
Giriş: 02/03/2005
Şehir: İpsala/Edirne
Mesaj: 2,968
Excel Vers. ve Dili:
ev: Ofis 2007- Win Xp iş: Ofis 2010- Win Vista
Varsayılan

sn ahmet daha yeni sabah oldu bakacağım ama garanti veremiyorum.
__________________
Felâket başa gelmeden evvel, onu önleyecek ve ona karşı savunulacak gerekleri düşünmek lâzımdır. Geldikten sonra dövünmenin faydası yoktur.[B]ATATÜRK[/B]

Türkler’den bahsediyorum. Düşmanına saldırırken amansız bir kasırgaya, korkunç bir denize ve insafsız bir yıldırıma benzeyen Türk; dost yanında ve silahsız düşman karşısında bir seher yelidir, berrak bir göldür. Gönül açan bu yeli yıldırmak, göz kamaştıran bu gölü coşkun bir denize çevirmek tabiatı da inciten bir gaflet olur.
[B]Tasso (İtalyan Şair)[/B]
hsayar Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 12:59   #10
hsayar
 
hsayar kullanıcısının avatarı
 
Giriş: 02/03/2005
Şehir: İpsala/Edirne
Mesaj: 2,968
Excel Vers. ve Dili:
ev: Ofis 2007- Win Xp iş: Ofis 2010- Win Vista
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
Felâket başa gelmeden evvel, onu önleyecek ve ona karşı savunulacak gerekleri düşünmek lâzımdır. Geldikten sonra dövünmenin faydası yoktur.[B]ATATÜRK[/B]

Türkler’den bahsediyorum. Düşmanına saldırırken amansız bir kasırgaya, korkunç bir denize ve insafsız bir yıldırıma benzeyen Türk; dost yanında ve silahsız düşman karşısında bir seher yelidir, berrak bir göldür. Gönül açan bu yeli yıldırmak, göz kamaştıran bu gölü coşkun bir denize çevirmek tabiatı da inciten bir gaflet olur.
[B]Tasso (İtalyan Şair)[/B]
hsayar Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 22:38


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - investing - Hurda - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu osgb - Lingerie - Dyeing Machine - Çorlu Temizlik- Hazır Site- SEO- Çorlu Burun Estetiği- Çorlu Pimapen- Karton Bardak- Marka Tescil Danışmanlık- Marmara Ereğlisi Restaurant- Çorlu Sigorta- Çorlu Pimapenci- İstanbul Avukat- Çorlu Sürücü Kursu- Çorlu Rehabilitasyon- Edirne Su Arıtma- Çorlu Perde Yıkama- Marmara Ereğlisi Hotel- Site Yönetimi- Led Aydınlatma-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden