Excel Makro (soru)

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

örnek dosya eklemeniz çözümü bulmayı kolaylaştırır
ayrıca dosya eklemek forum kuralıdır
iyi çalışmalar

(06/06/2024, 21:42)berduş yazdı: örnek dosya eklemeniz çözümü bulmayı kolaylaştırır
ayrıca dosya eklemek forum kuralıdır
iyi çalışmalar

Üstadım kusuruma bakmayın. Code üzerinden direkt anlaşılır diye düşündüm. Excel'i import ettim. Onun üzerinden kabaca izah edeyim.

Şimdi sadece filitrelenen veriyi kopyala komutunu ALL_DATA sayfasında kullanırsam onu alıp hedef yere tamamını kopyalıyor.

Bir altındaki kodu kullandığımda ise ALL_DATA'da ki 200 küsür satırdan filitre yapsam dahil rastgele 10 tanesini seçiyor. Bende bu durumla uğraşmamak için filitre yaptıktan sonra , filitrelenen veriyi manuel olarak Sheet1 taşıyorum. Ardından Sheet1 de o komut çalışacak şekilde düzenliyorum. Bu sefer sheet1 de zaten filitrelenmiş veri olduğu için içinden 10 tane rastgele satırı hedef sayfasına yazdırıyor.

Bu yüzden ilk komut ile ikincisi harmanlanarak o manuel işi ortadan kaldırsak. ALL_DATA ben sadece filitre yapsam ve komutu çalıştırdığımda o filitreyi görüp içinden sadece 10 tanesini hedefe yazdırsa. Ben sadece sürekli filitreyi değiştirsem aradaki elle yapılan ekstra işlemlerden beni kurtarmış olur.

çok teşekkürler.

aşağıdaki kodu dener misiniz?

Sub SecmeliRastGele()

Set Rng = ThisWorkbook.Worksheets("ALL_DATA").Range("A1:C10000").SpecialCells(xlCellTypeVisible)



      rowCount = WorksheetFunction.CountA(Rng) / Rng.Columns.Count

    If rowCount <= 10 Then

        ThisWorkbook.Worksheets("ALL_DATA").Range("A1:C10000").SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Worksheets("HedefSayfa").Range("A1")

        Exit Sub

    End If

    Dim dzSecil As Variant

    ReDim dzSecil(1 To rowCount)

  

    i = 0

    For Each xRw In Rng.Rows

    i = i + 1

        dzSecil(i) = xRw.Value2

        If rowCount = i Then GoTo 10

    Next xRw

10

Dim dctIndx As Object: Set dctIndx = CreateObject("Scripting.Dictionary")

    Do While dctIndx.Count < 10

    TmpTrh = Int((rowCount * Rnd) + 1)

        If TmpTrh > 1 Then If Not dctIndx.Exists(TmpTrh) Then dctIndx.Add TmpTrh, 0

    Loop

 

  Dim dzTmp() As Variant

 ReDim dzTmp(0 To dctIndx.Count, 2)

 x = 0

        dzTmp(x, 0) = dzSecil(1)(1, 1)

        dzTmp(x, 1) = dzSecil(1)(1, 2)

        dzTmp(x, 2) = dzSecil(1)(1, 3)

 For Each Ky In dctIndx.keys

 x = x + 1

        dzTmp(x, 0) = dzSecil(Ky)(1, 1)

        dzTmp(x, 1) = dzSecil(Ky)(1, 2)

        dzTmp(x, 2) = dzSecil(Ky)(1, 3)

 Next

ThisWorkbook.Worksheets("HedefSayfa").Range("A1").Resize(UBound(dzTmp) + 1, 3) = dzTmp

End Sub

(10/06/2024, 00:17)berduş yazdı: aşağıdaki kodu dener misiniz?

Sub SecmeliRastGele()

Set Rng = ThisWorkbook.Worksheets("ALL_DATA").Range("A1:C10000").SpecialCells(xlCellTypeVisible)



      rowCount = WorksheetFunction.CountA(Rng) / Rng.Columns.Count

    If rowCount <= 10 Then

        ThisWorkbook.Worksheets("ALL_DATA").Range("A1:C10000").SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Worksheets("HedefSayfa").Range("A1")

        Exit Sub

    End If

    Dim dzSecil As Variant

    ReDim dzSecil(1 To rowCount)

  

    i = 0

    For Each xRw In Rng.Rows

    i = i + 1

        dzSecil(i) = xRw.Value2

        If rowCount = i Then GoTo 10

    Next xRw

10

Dim dctIndx As Object: Set dctIndx = CreateObject("Scripting.Dictionary")

    Do While dctIndx.Count < 10

    TmpTrh = Int((rowCount * Rnd) + 1)

        If TmpTrh > 1 Then If Not dctIndx.Exists(TmpTrh) Then dctIndx.Add TmpTrh, 0

    Loop

 

  Dim dzTmp() As Variant

 ReDim dzTmp(0 To dctIndx.Count, 2)

 x = 0

        dzTmp(x, 0) = dzSecil(1)(1, 1)

        dzTmp(x, 1) = dzSecil(1)(1, 2)

        dzTmp(x, 2) = dzSecil(1)(1, 3)

 For Each Ky In dctIndx.keys

 x = x + 1

        dzTmp(x, 0) = dzSecil(Ky)(1, 1)

        dzTmp(x, 1) = dzSecil(Ky)(1, 2)

        dzTmp(x, 2) = dzSecil(Ky)(1, 3)

 Next

ThisWorkbook.Worksheets("HedefSayfa").Range("A1").Resize(UBound(dzTmp) + 1, 3) = dzTmp

End Sub

üstadım öncelikle eline sağlık. İstediğim gibi fakat birkaç  konu var düzeltilecek onuda yapabilirsen çok makbule geçer.
C sütunundaki verilerde duplicate olanı normalde getirmiyordu onu getiriyor şu anda.
Date/Time olan kısımda Hedef Sayfas'ına kopyalarken formatı tamamen değişiyor. Garip rakamlar çıkıyor
Bu kod her çalıştığında normalde varolanın sonuna eklerdi. Örn 1-10 11-21 21-31 31-41 gibi ekleyerek gidiyordu şuanda üstüne yazıyor.

c sütunundaki veriler zaten benzersiz değil mi?