Rastegele seçilen satrıları diğer sayfalara aktarmak

[mehmet131]

Merhabalar,

Sizden ricam çekiliş yapmak üzere kullanacağımız makroyu yapmamıza yardımcı olmanız.

Metin şeklinde yazarak zor oluyor oyüzden maddeler halinde yazıyorum

1. Sayfa1 deki verilerden isteğe bağlı sayıda rastgele çekiliş yapılır.

2. çekiliş sonucu seçilen satırlar 2.sayfaya kopyalanır.

Burada önemli olan satır halinde olması. Bilgisizliğimi bağışlayın. İlgilenenlere şimdiden teşekkürler.

 

[uyrdkl]

sayın leumruk'un bir çalışması var forumda sanırım işinizi görür.

http://www.excel.web.tr/f48/random-hucre-secme-t58576.html

 

[mehmet131]

inceledim hocam fakat farklı isteklerin yapıldığını gördüm. Belki bu bilgilere ufak şeyler eklenip sorun çözülebilirdi ama hiç deneyimim yok bu konularda.

Örnek dosya şekli
TC ADI SOYAD BABAADI TELEFON

bunlardan bazen 300 bazen 5000 olabiliyor. ve isteğe bağlı bazen 50 talihli bazen 100 talihli seçiliyor. seçilen talihlileri satırdaki tüm bilgilerin aktarılması lazım.

 

[leumruk]

Merhaba,
Örnek dosya ekleyiniz.

 

[mehmet131]

örnek dosyayı ekledim üstadım sayfa 1 de örnek için 8 satır mevcut 2.sayfaya 1 kişi seçildi mesela

ayrıca başka kaynaktan bulduğum örnek kodlar aşağıdaki gibidir. burada tek sıkıntı sadece ilk sutunu alması benim isteğim seçilmiş hücrenin bulunduğu tüm satırı 2. sayfaya kopyalaması gerek çünkü seçilen talihlinin numarasına vb bilgilere erişelim.

Sub Cekilis()

For i = 1 To 100

basla:

sira = Int(Rnd * 2500) + 1

If WorksheetFunction.CountIf(Sheets("Sayfa2").Range("A1:A100"), Sheets("Sayfa1").Cells(sira, 1)) = 0 Then
Sheets("Sayfa2").Cells(i, 1) = Sheets("Sayfa1").Cells(sira, 1)
Else
GoTo basla
End If
Next i
End Sub

 

[leumruk]

Merhaba,
Örneği inceleyiniz.

Sub Cekilis()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Cells.Delete
Say = Application.InputBox("Bir değer giriniz.")
If Say = False Then Exit Sub
tpl = s1.Cells(Rows.Count, 1).End(3).Row - 1
If Val(Say) > Val(tpl) Then
MsgBox "Belirttiğiniz sayı kayıtlı olandan fazla. Girebileceğiniz en yüksek değer: " & tpl, vbExclamation, "DEĞER FAZLA"
Exit Sub
End If
Randomize
For i = 1 To Say
basla:
sira = Int(Rnd * tpl) + 2
Set bul = s2.Range("A1:A100").Find(s1.Cells(sira, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not bul Is Nothing Then
If s1.Cells(sira, 2) = s2.Cells(bul.Row, 2) Then
GoTo basla
End If
End If
s1.Range(s1.Cells(sira, 1), s1.Cells(sira, 20)).Copy s2.Cells(i, 1)
Next i
MsgBox "İşlem tamamlandı.", vbInformation, "DURUM"
End Sub

 

[mekist]

Merhaba,
Örneği inceleyiniz.

Sub Cekilis()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Cells.Delete
Say = Application.InputBox("Bir değer giriniz.")
If Say = False Then Exit Sub
tpl = s1.Cells(Rows.Count, 1).End(3).Row - 1
If Val(Say) > Val(tpl) Then
MsgBox "Belirttiğiniz sayı kayıtlı olandan fazla. Girebileceğiniz en yüksek değer: " & tpl, vbExclamation, "DEĞER FAZLA"
Exit Sub
End If
Randomize
For i = 1 To Say
basla:
sira = Int(Rnd * tpl) + 2
Set bul = s2.Range("A1:A100").Find(s1.Cells(sira, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not bul Is Nothing Then
If s1.Cells(sira, 2) = s2.Cells(bul.Row, 2) Then
GoTo basla
End If
End If
s1.Range(s1.Cells(sira, 1), s1.Cells(sira, 20)).Copy s2.Cells(i, 1)
Next i
MsgBox "İşlem tamamlandı.", vbInformation, "DURUM"
End Sub

Lemruk Hocam,

Rastgele seçimde belirli bir sütunu dikkate alıyor mu? Komple satırdan mı rastgele seçim yapıyor