• DİKKAT

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

Random hücre seçme

A

anubis026

Katılım
15 Kasım 2008
Mesajlar
13
Excel Vers. ve Dili
Excel 2007
Arkadaşlar verilen bir isim listesini random şelkilde 3'erli gruplara ayırmam gerek.
3'e bölünemeyen rakamlarda kalan kişiler 1 yada 2 'li olarak kalıcak. En önemli sorunum bu hücreleri nasıl rassal seçerim.Ve hangi modüllerle bu kolay yapılır?
 
veriler hangi sütunlarda ABCDE...
random satırımız 5 olsun, abcde 5 yeni sayfayamı taşınacak.
diğer satırlar 6 ve 7 mi olacak onlarda ayrıca mı seçilecek?

örnek dosya eklermisiniz?
 
Selamlar...
1. Listeye isimleri giriyorsunuz. Ben kısa yoldan sayı girdim. 90 ismi girmeyi gözüm almadı. Hem sağlamasını yapmış oldum.

30 kişilik isim listesini girdikten sonra, butona basıyorsunuz. Kriter tablosundaki sayı dağılımına göre, Sonuç tablosuna isimler yerleşecektir.

Kura çekimi isim sayısında sınır yok. Yapmanız gereken Sonuç kısmındaki düşeyara formülündeki 32 sayısını artırmak.
NOT: Korhan Bey'den aldığım bir kod üzerinde uyarlama yaptım.
 

Ekli dosyalar

  • Kura.xls
    Kura.xls
    35.5 KB · Görüntüleme: 399
@leumruk,
çok teşekkürler kodlar için istediğimden çok daha gelişmiş bir kodlama bu,tek eksiği 3 farklı listede random liste oluşturması,yani benim istediğim girilen tek listede 3'erli grup oluşturmaktı,yani çok daha basiti.Şimdi bu dosyanın kodlarını anlamaya çalışıyorum.Bakalım yapabilecekmiyim.
@hsayar,
hocam sana da teşekkürler, dediğim gibi mesela A sütunu boyunca isimler girdik diyelim,bunu yanda 3 erli rassal gruplara ayırmak istemiştim.leumrukun verdiği kodlarla bunu deniyecem,leumruk sayıları rassal atayarak bunları hücrelere bağlamış.nasıl yaptığını anlamaya çalışıyorum şimdi,sağolun.
 
Kaç isim olacak. Ben üç gurubu rastgele eşleştireceğiz şeklinde anlamışım.
Anladığım kadarıyla isimler tek sütunda olacak.
 
evet isimler tek sütunda olacak,isim sayısı için bir sınırlama olmayacak 200'e kadar falan gitse yeterli.Bu sınıf mevcudunun rassal olarak gruplara ayrılması için kullanılacak.Yalnız senin gönderdiğin kodları anlayamadım hala uğraşıyorum.mesela kontrol sütunu ne işe yarıyor anlayamadım bi de mesela DÜŞEYARA diye bir fonksiyon çıkmış ortaya ama bunu vba kodunda yazmamışsın.Ben daha yeni sayılırım Excel VBA 'da onun için pek anlamadım buraları. Teşekkürler...
 
Kontrol sütunu, aynı sayıların yan yana gelmemesini sağlıyor. Dikkat ettiyseniz her ismin bir numarası var. Düşeyara bu numarayı bulup o numaranın yanındaki ismi getirmeye yarıyor.
 
Düşeyara mantığına Excel helpten bakıyorum şimdi,çözücem galiba ama baya zamanımı alıcak gibi daha bilmediğim çok komut var :)
 
Kod: 
Sub Karıştır()
Dim CardB(200) As Long
Dim i As Long, J As Long
For i = 1 To 200
   CardB(i) = i
Next i
Randomize Timer
For i = 1 To 200
        J = Int(Rnd * 200) + 1
        CardB(0) = CardB(i)
        CardB(i) = CardB(J)
        CardB(J) = CardB(0)
Next i
For x = 1 To 200
        Cells(x, 4) = CardB(x)
Next x
End Sub
Bir kod daha...
Bununla istediğinizi daha rahat halledersiniz. Ben hazırlayacaktım; ama vaktim olmadığından basit bir örnek hazırladım. Fikir verebilir.
B sütununa isimleri giriyorsunuz.(Ben denemek için yine sayı girdim.) Butona bastığınızda isimler rastgele karıştırılarak renkli sütuna sıralanır. İlk 30 birinci gurup, ikinci 30 ikici gurup...
Kod 200 kişi için düzenlenmiş, sayı değiştiğinde koddaki tüm 200'leri değiştirmeniz gerekir.
Renkli sütunu değiştirmeyin, Öğrenci sayısı düşeyera fonksiyonundaki 200'ü artırın. İlk hücreyi değiştirip aşağı sürüklerseniz formül otomatik kopyalanır.
 

Ekli dosyalar

Son düzenleme:
Tek sütun üzerinden 3'erli grup oluşturmaya çalışıyorum sizin verdiğiniz kodlardan yararlanarak ama bu kodlara göre tek sütundaki sayılar o sütun üzerinden rassal atanmış.Ben şimdi bu isimlere atanan sayıları 3'erli nasıl kolay atarım.Bi matris oluşturarak mı?o zaman da eğer kişi sayısı 3'e tam bölünemiyosa ne olcak ?
 
Mesajınızı yeni gördüm,çok teşekkürler kodlar için,uğraşıyorum bakalım.
 
sn anubis 302 kişilk gruptan 297 sini karıştırmayaı aşağıdaki kodlarla başardım
A sütununda isimler c de raporlamalar var siz örnek dosya eklerseniz daha iyi olur.

Kod: 
Sub gruplandır()
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim SnlTab() As Variant ', datGrp2() As Long
Dim arrDta() As Long, tabSnc() As Variant
'Dim tabGrp1() As Variant, tabGrp2() As Variant, tabSnc() As Variant
Dim i As Long, ii%, iii%   ', iStn%, iStr%, lngSnsNo1&, lngSnsNo0&, lngSnsNo2&
'Dim sonStr%
With Csf
  strDta = .Cells(65536, 1).End(xlUp).Row
  SnlTab = .Range("A1:A" & strDta)
  grpAdt = (strDta \ 3) + 1
  .Columns(3).Clear
  For i = 1 To (grpAdt * 25000)
  arrDta = UniqueRandomNumbers(3, LBound(SnlTab), UBound(SnlTab))
  
    If SnlTab(arrDta(1), 1) <> Empty And SnlTab(arrDta(2), 1) <> Empty And SnlTab(arrDta(3), 1) <> Empty Then
      ii = ii + 1
      ReDim Preserve tabSnc(1 To 4)
        tabSnc(1) = "G R U P _ " & ii
        tabSnc(2) = SnlTab(arrDta(1), 1)
        tabSnc(3) = SnlTab(arrDta(2), 1)
        tabSnc(4) = SnlTab(arrDta(3), 1)
        
        For iii = 1 To 3
          SnlTab(arrDta(iii), 1) = Empty
        Next iii
        strSnc = .Cells(65536, 3).End(xlUp).Row + 1
        
        .Range(.Cells(strSnc, 3), .Cells(strSnc + 3, 3)).Value = Application.Transpose(tabSnc)
    
        If ii = grpAdt Then GoTo son
    End If
  
  
  
  Next i
  
End With
Stop

son:
Set Csf = Nothing
Erase SnlTab, tabSnc, arrDta
End Sub

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
 
@hsayar
hocam çok teşekkürler ama kafam çok karıştı,ben daha çok yeniyim sizin yazmış olduğunuz kodları anlamadım maalesef.sn. lemrukun son verdiği kodları anladım sayılır,ama tabi bu tek sütunda işe yarıyor 3 sütunda bunu yapabilmek için yani 3 'erli oluşturmak için;
şimdi bu kodda önceden seçilmiş olan sayıyı tekrar diğer sütunda seçmemek için nasıl bir yöntem uygulamam gerek.Ben düşündüğümü uygulamaya geçiremiyorum. Size açıklayayım;
şimdi tek boyutlu bir matris oluştursam tıpkı sizin son verdiğiniz örnekteki gibi,buna girilen isimleri .offset.(xldown) komutlarıyla kontrol edip daha sonra kullandığınız rassal sayı atamaya göre bu isimleri (girilen isim sayısı/3,3) boyutunda bir matrise atasam bunun için de her sütun için yanına yine sayı dizisi koysam, syn leumrukun kullandığı düşeyara fonksiyonunu kullansam. Aklımdaki bu ama uygulayamıyorum.Altyapım çok yetersiz kusura bakmayın.
 
hocam lütfen örnek ekleyiniz valla benimde kafam karıştı.


aşağüıdaki kodla A sütunundakileri 3. katı olacak şekilde c sütununa gruplandırır. yani 300 veride işe yarar 301 ve 302 de işe yaramaz . onuda çözmye çalışıyorsdum ama mesajınızdan sorunuzun içeriğiniğn değiştiğini anlıyorum.
Ama siz a1, a100, a200 seçildiğinde beraberinde
b1, b100, b200, c1, c100, c200 de seçilsin diyorsanız öyle söyleyin ben bunu size sormuştum. sizde 4. mesajda a sütununa girilenleri yana 3 erli listelemeden bahsetmiştiniz.



Kod: 
Option Explicit

Sub gruplandır()
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim SnlTab() As Variant, SnlTabTemp() As Variant
Dim arrDta() As Long, tabSnc() As Variant
'Dim tabGrp1() As Variant, tabGrp2() As Variant, tabSnc() As Variant
Dim i%, ii%, iii%
Dim y%, yy%, yyy%
Dim sonStr As Long, grpAdt%
With Csf
  sonStr = .Cells(65536, 1).End(xlUp).Row
  SnlTab = Application.Transpose(.Range("A1:A" & sonStr))
  grpAdt = (sonStr \ 3)
  If (sonStr \ 3) <> (sonStr / 3) Then
    MsgBox "Tablonuzdaki değer sayısı 3 ün katı olmadığından ilk " & grpAdt * 3 & " değer dikkate alınacaktır!"
  End If
  .Columns(3).Clear
  For i = 1 To (grpAdt * 5)
  arrDta = UniqueRandomNumbers(3, LBound(SnlTab, 1), UBound(SnlTab, 1))
    If SnlTab(arrDta(1)) <> Empty And SnlTab(arrDta(2)) <> Empty And SnlTab(arrDta(3)) <> Empty Then
      ii = ii + 1
      ReDim Preserve tabSnc(1 To 4)
        tabSnc(1) = "G R U P _ " & ii
        tabSnc(2) = SnlTab(arrDta(1))
        tabSnc(3) = SnlTab(arrDta(2))
        tabSnc(4) = SnlTab(arrDta(3))
        For iii = 1 To 3
          SnlTab(arrDta(iii)) = Empty
        Next iii
        iii = 0
'------------------
'Kullandıklarımızı diziden çıkartıp geçici diziye alacağzı, sonra gerçek dizimize geri vereceğiz.
        For y = LBound(SnlTab) To UBound(SnlTab)
          If SnlTab(y) <> Empty Then
            yy = yy + 1
            ReDim Preserve SnlTabTemp(1 To yy)
            SnlTabTemp(yy) = SnlTab(y)
          End If
        Next y
        y = 0: yy = 0: Erase SnlTab
        SnlTab = SnlTabTemp
        Erase SnlTabTemp() ', Data: yy = 0
'-------------
        sonStr = .Cells(65536, 3).End(xlUp).Row + 1
        .Range(.Cells(sonStr, 3), .Cells(sonStr + 3, 3)).Value = Application.Transpose(tabSnc)
    
        If ii = grpAdt Then GoTo son
    End If
  Next i
  i = 0: ii = 0
End With

son:
Set Csf = Nothing
Erase SnlTab, tabSnc, arrDta
End Sub

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
'kaçadetsayı = IIf(UBound(SnlTab, 1) >= 3, 3, UBound(SnlTab, 1))
 
hsayar,
Hocam çok teşekkürler yardımlarınız için.Son verdiğiniz kod tam istediğim gibi,doğru anlamışsınız.Şimdi sizin de söylediğiniz gibi 3'ün katları olmadığında kalan 1 yada 2 kişiyi de bir grup yapmam gerek.Şimdi bunun nasıl çözüleceğine dair, siz nasıl bi çözüm düşünüyosunuz söylermisiniz? ben de yapmaya çalışayım. Sabahtan beri uğraşıyorum,soğumaya başladım bu işten.Bize derslerde öğretilen son yazdığınız kodun ancak 10'a 1 ini anlamamı sağlıyor.
 
sn anubis026 kafamuı yine karıştırdınız az önce a sütununa birleşik olanlarıda taşıyacağım diyordurunuz.
ona göre kodlar şöyle olmalı abc sütunlarında ad, soyad, babaadı bilgileri olsun. bunları HIJ sütunlarına gruplamak için;

Kod: 
[URL="http://www.excel.web.tr/../member.php?u=112039"][/URL]

şimdi artıklarıda mı gruplmak istiyorsunuz
 
dilimden döndüğümce anlattım;
Kod: 
Option Explicit

Sub gruplandı()
'16/11/2008-17:41
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim SnlTab() As Variant, SnlTabTemp() As Variant
Dim arrDta() As Long, tabSnc() As Variant
'Dim tabGrp1() As Variant, tabGrp2() As Variant, tabSnc() As Variant
Dim i%, ii%, iii%
Dim y%, yy%, yyy%
Dim sonStr As Long, grpAdt%
With Csf
  sonStr = .Cells(65536, 1).End(xlUp).Row
  SnlTab = .Range("A1:C" & sonStr)      'verilerimizi dizi değişkene atıyoruz. burada kontrol edeceğiz.
  grpAdt = (sonStr \ 3)                 'verilerimizi 3 bölüyoruz ve sonucu tamsayı olarak istiyoruz.
  If (sonStr \ 3) <> (sonStr / 3) Then
    MsgBox "Tablonuzdaki değer sayısı 3 ün katı olmadığından ilk " & grpAdt * 3 & " değer dikkate alınacaktır!"
  End If
  'çıktıların geleceği kolonu temile diyoruz....
  .Columns(8).Clear
  .Columns(9).Clear
  .Columns(10).Clear

' 1 den kaç adet grup gelecekse 5 katına kadar döngü oluşturuyoruz.
'neden, koşula uymayanlar olduğu zaman yarıda kesip çıkmasın diye.
  For i = 1 To (grpAdt * 5)
  arrDta = UniqueRandomNumbers(3, LBound(SnlTab, 1), UBound(SnlTab, 1)) 'üç adet benzersiz rastgele sayı istedik.
    'seçilen sayılar dizide boş mu değilmi kontrol ettik.
    If SnlTab(arrDta(1), 1) <> Empty And SnlTab(arrDta(2), 1) <> Empty And SnlTab(arrDta(3), 1) <> Empty Then
    'boş değilse işlemimize devam edebiliriz.
      ii = ii + 1
      ReDim Preserve tabSnc(1 To 4, 1 To 3)
        tabSnc(1, 1) = "G R U P _ " & ii     'sonuç değişkenine grup başlığını atadık
        tabSnc(2, 1) = SnlTab(arrDta(1), 1)  ' " grubun 1. elamanın adını atadık.
        tabSnc(3, 1) = SnlTab(arrDta(2), 1)  ' " grubun 1. elamanın soyadını atadık.
        tabSnc(4, 1) = SnlTab(arrDta(3), 1)  ' " grubun 1. elamanın babaadını atadık.
        tabSnc(2, 2) = SnlTab(arrDta(1), 2)  ' " grubun 2. elamanın adını atadık.
        tabSnc(3, 2) = SnlTab(arrDta(2), 2)  '.....
        tabSnc(4, 2) = SnlTab(arrDta(3), 2)
        tabSnc(2, 3) = SnlTab(arrDta(1), 3)
        tabSnc(3, 3) = SnlTab(arrDta(2), 3)
        tabSnc(4, 3) = SnlTab(arrDta(3), 3)
        sonStr = .Cells(65536, 8).End(xlUp).Row + 1   'h sütunundaki ilk boş satırı tespit ettik.
        .Range(.Cells(sonStr, 8), .Cells(sonStr + 3, 8 + 2)).Value = tabSnc ' hıj aralığındaki 4 satıra sonuç yazdık.

'------------------
'Kullandıklarımızı diziden çıkartıp geçici diziye alacağız, sonra gerçek dizimize geri vereceğiz.
'önce içlerini boşaltıyoruz....
        For iii = 1 To 3
          SnlTab(arrDta(iii), 1) = Empty
          SnlTab(arrDta(iii), 2) = Empty
          SnlTab(arrDta(iii), 3) = Empty
        Next iii
        iii = 0
'sonra içi boş olanları diziden atıyoruz. diziler için orjinal REMOVE konutu yoksa işe yarar. araştırmadım.
        For y = LBound(SnlTab, 1) To UBound(SnlTab, 1)
          If SnlTab(y, 1) <> Empty Then
            yy = yy + 1
            ReDim Preserve SnlTabTemp(1 To 3, 1 To yy)
            SnlTabTemp(1, yy) = SnlTab(y, 1)
            SnlTabTemp(2, yy) = SnlTab(y, 2)
            SnlTabTemp(3, yy) = SnlTab(y, 3)
          End If
        Next y
        y = 0: yy = 0: Erase SnlTab
        SnlTab = Application.Transpose(SnlTabTemp)
        Erase SnlTabTemp() ', Data: yy = 0
'-------------
'eğer ii değeri grup adetine döngüden önce ulaşırsa ben alacağım aldım sen de istirahet et deyip çıkıyoruz.
        If ii = grpAdt Then GoTo son
    End If
  Next i
  i = 0: ii = 0
End With

son:
Set Csf = Nothing
Erase SnlTab, tabSnc, arrDta
End Sub

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
'kaçadetsayı = IIf(UBound(SnlTab, 1) >= 3, 3, UBound(SnlTab, 1))
 

Ekli dosyalar

Evet hocam artıkları da gruplamak istiyordum.ama çok da önemli değil siz fazlasıyla istediğim kodları verdiniz teşekkürler.
 
Kod: 
Option Explicit

Sub gruplandı()
'16/11/2008-17:41
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim SnlTab() As Variant, SnlTabTemp() As Variant
Dim arrDta() As Long, tabSnc() As Variant
'Dim tabGrp1() As Variant, tabGrp2() As Variant, tabSnc() As Variant
Dim i%, ii%, iii%
Dim y%, yy%, yyy%
Dim sonStr As Long, grpAdt%, artık%, fark
With Csf
  sonStr = .Cells(65536, 1).End(xlUp).Row
  SnlTab = .Range("A1:C" & sonStr)      'verilerimizi dizi değişkene atıyoruz. burada kontrol edeceğiz.
  grpAdt = (sonStr \ 3)                 'verilerimizi 3 bölüyoruz ve sonucu tamsayı olarak istiyoruz.
  fark = sonStr - (grpAdt * 3)
  If (sonStr \ 3) <> (sonStr / 3) Then
    MsgBox "Tablonuzdaki değer sayısı 3 ün katı olmadığından ilk " & grpAdt * 3 & " değer dikkate alınacaktır!"
  End If
  'çıktıların geleceği kolonu temile diyoruz....
  .Columns(8).Clear
  .Columns(9).Clear
  .Columns(10).Clear

' 1 den kaç adet grup gelecekse 5 katına kadar döngü oluşturuyoruz.
'neden, koşula uymayanlar olduğu zaman yarıda kesip çıkmasın diye.
  For i = 1 To (grpAdt * 5)
  arrDta = UniqueRandomNumbers(3, LBound(SnlTab, 1), UBound(SnlTab, 1)) 'üç adet benzersiz rastgele sayı istedik.
    'seçilen sayılar dizide boş mu değilmi kontrol ettik.
    If SnlTab(arrDta(1), 1) <> Empty And SnlTab(arrDta(2), 1) <> Empty And SnlTab(arrDta(3), 1) <> Empty Then
    'boş değilse işlemimize devam edebiliriz.
      ii = ii + 1
      ReDim Preserve tabSnc(1 To 4, 1 To 3)
        tabSnc(1, 1) = "G R U P _ " & ii     'sonuç değişkenine grup başlığını atadık
        tabSnc(2, 1) = SnlTab(arrDta(1), 1)  ' " grubun 1. elamanın adını atadık.
        tabSnc(3, 1) = SnlTab(arrDta(2), 1)  ' " grubun 1. elamanın soyadını atadık.
        tabSnc(4, 1) = SnlTab(arrDta(3), 1)  ' " grubun 1. elamanın babaadını atadık.
        tabSnc(2, 2) = SnlTab(arrDta(1), 2)  ' " grubun 2. elamanın adını atadık.
        tabSnc(3, 2) = SnlTab(arrDta(2), 2)  '.....
        tabSnc(4, 2) = SnlTab(arrDta(3), 2)
        tabSnc(2, 3) = SnlTab(arrDta(1), 3)
        tabSnc(3, 3) = SnlTab(arrDta(2), 3)
        tabSnc(4, 3) = SnlTab(arrDta(3), 3)
        sonStr = .Cells(65536, 8).End(xlUp).Row + 1   'h sütunundaki ilk boş satırı tespit ettik.
        .Range(.Cells(sonStr, 8), .Cells(sonStr + 3, 8 + 2)).Value = tabSnc ' hıj aralığındaki 4 satıra sonuç yazdık.
        Erase tabSnc
'------------------
'Kullandıklarımızı diziden çıkartıp geçici diziye alacağız, sonra gerçek dizimize geri vereceğiz.
'önce içlerini boşaltıyoruz....
        For iii = 1 To 3
          SnlTab(arrDta(iii), 1) = Empty
          SnlTab(arrDta(iii), 2) = Empty
          SnlTab(arrDta(iii), 3) = Empty
        Next iii
        iii = 0
        Erase arrDta
'sonra içi boş olanları diziden atıyoruz. diziler için orjinal REMOVE konutu yoksa işe yarar. araştırmadım.
        For y = LBound(SnlTab, 1) To UBound(SnlTab, 1)
          If SnlTab(y, 1) <> Empty Then
            yy = yy + 1
            ReDim Preserve SnlTabTemp(1 To 3, 1 To yy)
            SnlTabTemp(1, yy) = SnlTab(y, 1)
            SnlTabTemp(2, yy) = SnlTab(y, 2)
            SnlTabTemp(3, yy) = SnlTab(y, 3)
          End If
        Next y
        y = 0: yy = 0: Erase SnlTab
        On Error Resume Next
        'SnlTabTemp değeri boşaldığı için atamayı yapamıyorum. boş oılup olmadığınıda kontrol edemediğim için böye geçtim.
        SnlTab = Application.Transpose(SnlTabTemp)
        On Error GoTo 0
        Erase SnlTabTemp() ', Data: yy = 0
        If ii >= grpAdt And fark = 0 Then GoTo son

        If grpAdt = ii Then
          artık = UBound(SnlTab, 1)
          ReDim Preserve tabSnc(1 To artık + 1, 1 To 3)
          tabSnc(1, 1) = "G R U P _ " & ii + 1   'sonuç değişkenine grup başlığını atadık
          For yyy = 2 To artık + 1
            tabSnc(yyy, 1) = SnlTab(yyy - 1, 1) ' " grubun 1. elamanın adını atadık.
            tabSnc(yyy, 2) = SnlTab(yyy - 1, 2) ' " grubun 1. elamanın adını atadık.
            tabSnc(yyy, 3) = SnlTab(yyy - 1, 3) ' " grubun 1. elamanın adını atadık.
          Next yyy
          sonStr = .Cells(65536, 8).End(xlUp).Row + 1   'h sütunundaki ilk boş satırı tespit ettik.
          .Range(.Cells(sonStr, 8), .Cells(sonStr + artık, 8 + 2)).Value = tabSnc ' hıj aralığındaki 4 satıra sonuç yazdık.
          Erase tabSnc
          GoTo son
        End If

    End If
  Next i
  i = 0: ii = 0
End With

son:
Set Csf = Nothing
Erase SnlTab, tabSnc, arrDta
End Sub

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
'kaçadetsayı = IIf(UBound(SnlTab, 1) >= 3, 3, UBound(SnlTab, 1))

bunlarla artıklarda oluyor.... :;)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst