+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Excel Makro (soru) (/konu-excel-makro-soru.html)
Sayfalar:
1
2
Excel Makro (soru) - haandsomee_tr - 06/06/2024
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
RE: Excel Makro (soru) - berduş - 06/06/2024
örnek dosya eklemeniz çözümü bulmayı kolaylaştırır
ayrıca dosya eklemek forum kuralıdır
iyi çalışmalar
RE: Excel Makro (soru) - haandsomee_tr - 07/06/2024
(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.
RE: Excel Makro (soru) - berduş - 10/06/2024
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 SubRE: Excel Makro (soru) - haandsomee_tr - 10/06/2024
(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.
RE: Excel Makro (soru) - berduş - 10/06/2024
c sütunundaki veriler zaten benzersiz değil mi?