İstenilen sayı kadar. Rastgele isim belirleme.

[Bora K]

Merhabalar
D2 hücresine yazacağım sayı kadar C sütunundan rastgele
isim seçilip G2 den itibaren listelenecek.
İsimlerle beraber F sütununa da sınıf noları gelecek.

Konuya hakim değerli uzmanlarımızın yardımlarını bekliyorum.
Saygılarımla.

 

[Necdet]

Merhaba,

Kodları dener misiniz?

Sub Kura()
 
    Dim Bs  As Integer, _
        Bt  As Integer, _
        Say As Integer, _
        Adt As Integer, _
        d1() As String, _
        d2() As String
 
    Bt = Cells(Rows.Count, "C").End(3).Row - 1
    On Error Resume Next
 
    ReDim d1(1 To Range("D2"))
    ReDim d2(1 To Range("D2"))
 
    Range("F1:G" & Rows.Count).ClearContents
    Randomize
 
    Do
        Say = Int((Bt * Rnd) + 1) + 1
        Bs = Application.Match(Range("C" & Say), Application.Transpose(d2), 0)
        If Bs = 0 Then
            Adt = Adt + 1
            d1(Adt) = Range("B" & Say)
            d2(Adt) = Range("C" & Say)
        End If
    Loop While Adt < Range("D2")
 
    Range("F2").Resize(Range("D2"), 1) = Application.WorksheetFunction.Transpose(d1)
    Range("G2").Resize(Range("D2"), 1) = Application.WorksheetFunction.Transpose(d2)
 
End Sub

 

[Bora K]

Merhabalar Necdet Hocam.
Konuya alakanız için çok teşekkür ederim.

İlgili alana 3 yazıp seçim yap dediğimde;

1 B Özgür Çelik
3 G Zehra Peker
1 B Özgür Çelik

bu şekilde bir sonuç çıkarttı. Görüldüğü üzere mükerrer kayıt geldi tesadüfen.
Kod okuma kabiliyetim olmadığı için yazayım dedim. Bu durumun önüne geçilebilirse
şayet daha iyi olabilir.

 

[Muhammet Okumuş]

Alternatif olsun.

Sub Rastgele()
Application.ScreenUpdating = False
son = Cells(Rows.Count, "C").End(3).Row
Range("E2:E" & son) = "=ROW(A1)"
Range("F2:F" & son) = "=RAND()"
Range("E2:F" & son) = Range("E2:F" & son).Value
Range("E2:F" & son).Sort Range("F2")
Range("F2:F" & son) = ""
Range("F2:G" & Range("D2") + 1) = "=OFFSET(B$1,$E2,0)"
Range("F2:G" & Range("D2") + 1) = Range("F2:G" & Range("D2") + 1).Value
Range("E:E") = ""
End Sub

 

[Necdet]

Merhabalar Necdet Hocam.
Konuya alakanız için çok teşekkür ederim.

İlgili alana 3 yazıp seçim yap dediğimde;

1 B Özgür Çelik
3 G Zehra Peker
1 B Özgür Çelik

bu şekilde bir sonuç çıkarttı. Görüldüğü üzere mükerrer kayıt geldi tesadüfen.
Kod okuma kabiliyetim olmadığı için yazayım dedim. Bu durumun önüne geçilebilirse
şayet daha iyi olabilir.

Bende o hatayı anlar anlamaz kodları silmiştim ama siz baya hızlı davranmışsınız.

Kodlar yenilendi.

 

[Necdet]

Merhaba,

Tebrikler Muhammet bey, yöntem baya iyi hiç aklıma gelmemişti.

 

[Bora K]

Sayğıdeğer Necdet Hocam
Yenilenen kodu denedim lakin sonuç alamadım
kod çalışmaya başlayınca donma oluyor.

Sayın Okumuş konuya alakanız için çok teşekkür ederim.
Sizin kod hatasız çalışıyor.
Eğer uygun görürseniz bir sütun daha ilave etmek istiyoruz koda.
Gerekli düzeltmeyi ekte yaptım. Saygılar.

 

[Muhammet Okumuş]

Hocam sizler sayesinde bir şeyler yapmaya çalışıyoruz.

 

[Muhammet Okumuş]

Kodları bu şekil deneyiniz.

Sub Rastgele()
Application.ScreenUpdating = False
Range("H:J")= ""
son = Cells(Rows.Count, "C").End(3).Row
Range("G2:G" & son) = "=ROW(A1)"
Range("H2:H" & son) = "=RAND()"
Range("G2:H" & son) = Range("G2:H" & son).Value
Range("G2:H" & son).Sort Range("H2")
Range("H2:H" & son) = ""
Range("H2:J" & Range("F2") + 1) = "=OFFSET(B$1,$G2,0)"
Range("H2:J" & Range("F2") + 1) = Range("H2:J" & Range("F2") + 1).Value
Range("G:G") = ""
End Sub

 

[Bora K]

Sayın Okumuş;
Değerli Üstad kod harika oldu.

Ekstradan verdiğimiz rahatsızlık için özür dileriz.
Hakkınızı helal edin.

Saygılar.

 

[Necdet]

Sayğıdeğer Necdet Hocam
Yenilenen kodu denedim lakin sonuç alamadım
kod çalışmaya başlayınca donma oluyor.

Sayın Okumuş konuya alakanız için çok teşekkür ederim.
Sizin kod hatasız çalışıyor.
Eğer uygun görürseniz bir sütun daha ilave etmek istiyoruz koda.
Gerekli düzeltmeyi ekte yaptım. Saygılar.

Kod aynı kişi çıkmasın diye sürekli arama yapıyor, beklemesinin nedeni o.

Sayın Muhammet beyin yöntemi daha iyi, onu kullanınız.

 

[Bora K]

İlgi ve alakanız için
Çok teşekkür ederim Necdet Hocam
Herşey gönlünüzce olsun inşallah.

Saygılar.

 

[Muhammet Okumuş]

Sayın Okumuş;
Değerli Üstad kod harika oldu.

Ekstradan verdiğimiz rahatsızlık için özür dileriz.
Hakkınızı helal edin.

Saygılar.

Rica ederim. İyi çalışmalar.

Sn Necdet Bey,
Fonksiyonları makrolarla birlikte kullanmak bazı durumlarda işlemleri çok hızlandırıyor. Özellikle döngü yerine fonksiyonlarla beraber işlemi yapmaya çalışıyorum