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 09-11-2008, 13:16   #11
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

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
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 13:46   #12
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

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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.
    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
'/// 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
__________________
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, 13:49   #13
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

Alıntı:
ahmett46 tarafından gönderildi Mesajı Görüntüle
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...
__________________
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, 14:04   #14
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

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
Eklenmiş Dosyalar
Dosya Türü: rar toto.rar (45.3 KB, 129 Görüntülenme)
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 14:37   #15
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

Alıntı:
ahmett46 tarafından gönderildi Mesajı Görüntüle
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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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, 8), .Cells(16, 107))
    .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, 4), .Cells(iStr, 6)).Select
      Exit Sub
    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
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
Eklenmiş Dosyalar
Dosya Türü: xls toto_hsr(çözüm).xls (166.0 KB, 221 Görüntülenme)
__________________
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]

Bu mesaj en son " 09-11-2008 " tarihinde saat 14:44 itibariyle hsayar tarafından düzenlenmiştir....
hsayar Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 15:27   #16
janveljan
 
Giriş: 27/07/2004
Mesaj: 719
Excel Vers. ve Dili:
Excel 2003 Tr
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
Excel 2003 Türkçe
janveljan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 15:53   #17
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

teşekkürler hocam tam istediğim gibi olmuş elinize sağlık
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 16:15   #18
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

rica edeirm sn ahmet
__________________
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, 18:26   #19
ahmett46
 
Giriş: 01/02/2007
Mesaj: 516
Excel Vers. ve Dili:
excel2003
Varsayılan

Hocam çok oldun diyeceksin ama ikinci bir butonla sütunları kontrol edecek aynı sütunları farklı birrenge boyayacak mümkün mü acaba?
ahmett46 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 09-11-2008, 18:56   #20
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

aynı sütunlar derken neyi kastetiğini anlamadım.
__________________
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:19


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 - Kobi Danışmanlık - Tekirdağ Samsung - 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- Didim Çatı İnşaat
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden