Hocalarım,
Bir çok sorumun cevabını burada buldum herkesin eline emeğine sağlık. Şöyle bir sorum olacak
Elimde 2 satır bağımsız makro kodu var.
Bir tanesi bir sayfadaki filitrelenmiş öğeleri yapılan filitreye göre diğer sayfaya kopyalıyor.
Diğeri ise yine aynı sayfadaki öğeleri filitresine bakmayarak sadece 10 tane random şekilde ve benzersiz olacak şekilde başka sayfaya alıyor. Aslında benim isteğim bu iki kodun birleşimi. İkincisinin görevini yapsın fakat filitrelenen içeriği görsün diğerlerini görmesin.
Sadece filitrelenen alanı kopyalayan Komut
Sub FiltreyiKopyala()
Sheets("Sheet1").Range("A1:C10000").SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("HedefSayfa").Range("A1")
End Sub
Benzersiz random 10 tane kopyalayak komut :
Sub KopyalaBenzersizRastgeleSatir()
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim tbl As ListObject
Dim rowCount As Integer
Dim uniqueRowCount As Integer
Dim randomRowIndex As Integer
Dim copiedRowCount As Integer
Dim uniqueRows() As Boolean
Dim i As Integer
Dim newRow As Long
' Kaynak ve hedef sayfalari tanimla
Set wsSource = ThisWorkbook.Sheets("Sheet1") ' Kaynak sayfa adini değistirebilirsin
Set wsDestination = ThisWorkbook.Sheets("Hedef") ' Hedef sayfa
' Kaynak tablo ve satir sayisini al
Set tbl = wsSource.ListObjects("Table1") ' Kaynak tablo adini değistirebilirsin
rowCount = tbl.ListRows.Count
' Eğer tabloda 10 satirdan az varsa, tüm satirlari kopyala ve çik
If rowCount <= 10 Then
tbl.DataBodyRange.Copy Destination:=wsDestination.Range("A")
Exit Sub
End If
' Her satirin bir kez kopyalanip kopyalanmadiğini izlemek için bir dizi olustur
ReDim uniqueRows(1 To rowCount)
' Benzersiz satir sayisini sifirla
uniqueRowCount = 0
' Tüm satirlari kopyalanmamis olarak isaretle
For i = 1 To rowCount
uniqueRows(i) = True
Next i
' Rastgele 10 benzersiz satir seçene kadar devam et
Do While copiedRowCount < 10 And uniqueRowCount < rowCount
randomRowIndex = Int((rowCount * Rnd) + 1)
' Eğer seçilen satir daha önce kopyalanmadiysa, kopyala
If uniqueRows(randomRowIndex) Then
tbl.ListRows(randomRowIndex).Range.Copy
uniqueRows(randomRowIndex) = False
copiedRowCount = copiedRowCount + 1
' Kopyalanan satirlari hedef sayfaya yapistir
newRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
wsDestination.Cells(newRow, "A").PasteSpecial Paste:=xlPasteAll
End If
' Benzersiz satir sayisini artir
uniqueRowCount = uniqueRowCount + 1
Loop
' Panoyu temizle
Application.CutCopyMode = False
End Sub
#1
