Soru Rastgele Seçim

[Mukteda]

.
.
Merhaba,
Ekte gönderdiğim örnek dosyada, RAPOR sayfasındaki E1 hücresindeki seçim sayısı kadar, ilgili başlıkların altına VERİ sayfasından alıp yazacaktır.

Fonksiyon veya VBA fark etmez nasıl yapabilirim?

Not: Gerçek dosyada VERİ sayfasında 3.000 Satır veri vardır.

RASTGELE SEÇİM.xlsx - 14 KB

.

 

[mesuttasar]

VERİ sayfasının ismini VERI olarak değiştirip aşağıdaki kodları dener misiniz?
Benzersiz verileri seçmek için kodun üstünde biraz daha değişiklik yapmak gerekebilir.

Sub test()
Dim adet, satir, rastgele As Long
adet = Sheets("RAPOR").Range("E1")
satir = Sheets("VERI").[A100000].End(3).Row
For j = 1 To adet
rastgele = Int(satir * Rnd) + 2
if rastgele> satir then rastgele=satir
Sheets("VERI").Range("A" & rastgele & ":C" & rastgele).Copy
satir2 = Sheets("RAPOR").[A100000].End(3).Row
Sheets("RAPOR").Cells(satir2 + 1, 1).Select
ActiveSheet.Paste
Next j
End Sub

 

[Mukteda]

.
Merhaba Mesut Bey,

İşlem tamamdır. Yardımınız için çok teşekkür ederim.
Dosyanın bir kaç ufak kıyısını köşesini düzeltebilir miyiz?

*/*/*

VERI Sayfasında raporlama sonrası kopyalama animasyonu devam ediyor. ENTER veya ESC yapmak gerekiyor.
RAPOR Sayfasına direk tablo biçimi ile yapıştırıyor. Değerler ve sayı biçimlendirmesi olacak şekilde düzeltebilir misiniz?
RAPOR Sayfasında veri varsa en alta yapıştırıyor. İlk önce "başlıkların en altında ne varsa" temizleyip sonra RASTGELE seçim yaptırabilir misiniz?

Kolay gelsin.

 

[veyselemre]

VERİ sayfasının ismini VERI olarak değiştirip aşağıdaki kodları dener misiniz?
Benzersiz verileri seçmek için kodun üstünde biraz daha değişiklik yapmak gerekebilir.

Sub test()
Dim adet, satir, rastgele As Long
adet = Sheets("RAPOR").Range("E1")
satir = Sheets("VERI").[A100000].End(3).Row
For j = 1 To adet
rastgele = Int(satir * Rnd) + 2
if rastgele> satir then rastgele=satir
Sheets("VERI").Range("A" & rastgele & ":C" & rastgele).Copy
satir2 = Sheets("RAPOR").[A100000].End(3).Row
Sheets("RAPOR").Cells(satir2 + 1, 1).Select
ActiveSheet.Paste
Next j
End Sub

Yukarıdaki kod tekrar aynı veriyi kopyalayabilir.

Sub test()
    Dim veri, i, ii, iii, tmp, adet
    Randomize Timer
    With Sheets("VERİ")
        veri = .Range("A2:D" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With
    For i = 1 To UBound(veri)
        veri(i, 4) = Rnd
    Next i
    For i = 1 To UBound(veri) - 1
        For ii = i + 1 To UBound(veri)
            If veri(i, 4) > veri(ii, 4) Then
                For iii = 1 To 4
                    tmp = veri(i, iii)
                    veri(i, iii) = veri(ii, iii)
                    veri(ii, iii) = tmp
                Next iii
            End If
        Next ii
    Next i
    With Sheets("RAPOR")
        .Range("A2:C" & .Cells(Rows.Count, 1).End(3).Row).Clear
        adet = .Range("E1").Value
        If adet > UBound(veri) Then adet = UBound(veri)
        With .Range("A2:C2").Resize(adet)
            .Value = veri
            .Borders.LineStyle = xlContinuous
            .Columns.AutoFit
        End With
    End With

End Sub

 

[mesuttasar]

Kıyısı köşesi düzeltilmiş kodlar aşağıdadır.

Sub test()
Dim adet, satir, rastgele, j, satir2 As Long
adet = Sheets("RAPOR").Range("E1")
satir = Sheets("VERI").[A100000].End(3).Row
    Range("A2:C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp

    For j = 1 To adet
    rastgele = Int(satir * Rnd) + 2
        If rastgele > satir Then rastgele = satir
    Sheets("VERI").Range("A" & rastgele & ":C" & rastgele).Copy
    satir2 = Sheets("RAPOR").[A100000].End(3).Row
    Sheets("RAPOR").Cells(satir2 + 1, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Next j
Sheets("VERI").Select
Application.CutCopyMode = False
Sheets("RAPOR").Select
End Sub

 

[Mukteda]

Yukarıdaki kod tekrar aynı veriyi kopyalayabilir.

Tamamdır Veysel Bey,

İlgi ve yardımınız için teşekkür ederim.

Kolay gelsin.

 

[Mukteda]

Kıyısı köşesi düzeltilmiş kodlar aşağıdadır.

Eyvallah Mesut Bey,
Run-time error '9' hatası verdi. Son kez bakabilir misiniz?

 

[mesuttasar]

Run-time error 9 hatası sayfa isminden kaynaklanıyor sanıyorum, sayfa isminde büyük İ harfini I harfi ile değiştirirseniz sorun çözülür, benzersiz seçimler yapmak içinde @veyselemre bey'in kodlarına alternatif olarak aşağıdaki kodları kullanabilirsiniz.

Sub test()
Dim adet, satir, rastgele, j, satir2 As Long
adet = Sheets("RAPOR").Range("E1")
satir = Sheets("VERI").[A100000].End(3).Row
    Range("A2:C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp

    For j = 1 To adet
10
    rastgele = Int(satir * Rnd) + 2
    If Sheets("VERI").Cells(rastgele, 4) = "X" Then GoTo 10
     If rastgele > satir Then rastgele = satir
        Sheets("VERI").Cells(rastgele, 4) = "X"
        Sheets("VERI").Range("A" & rastgele & ":C" & rastgele).Copy
        Sheets("RAPOR").Select
        satir2 = [A100000].End(3).Row
        
        Sheets("RAPOR").Cells(satir2 + 1, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Next j
    
Sheets("VERI").Select
Sheets("VERI").Columns(4).Delete
Application.CutCopyMode = False
Sheets("RAPOR").Select
End Sub

 

[Mukteda]

aşağıdaki kodları kullanabilirsiniz.

Geç yanıt verdiğim için özür dilerim.

İşlem tamamdır. Emeğinize, gönlünüze sağlık... Hakkınızı helal ediniz.

Sağlıklı günler dilerim.