Sayfa isimlerini kendinize gore degistirdikten sonra, asagidakini kullanin.
[vb:1:ccb113484f]Sub Test()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim MyRng As Range
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Sh2.Range("A1:A" & Sh2.Range("A65536").End(xlUp).Row).Clear
For Each MyRng In Sh1.Range("A1:A100")
If MyRng.Interior.ColorIndex = 6 Then
Sh2.Range("A" & Sh2.Range("A65536").End(xlUp).Row + 1) = MyRng
End If
Next
End Sub
[/vb:1:ccb113484f]
[vb:1:a527094dcd]c = 0
For a = 1 To 100
If Sheets("sayfa1").Cells(a, 1).Interior.ColorIndex = 6 Then
c = c + 1
Sheets("sayfa2").Cells(c, 1) = Sheets("sayfa1").Cells(a, 1).Value
End If
Next a
[/vb:1:a527094dcd]
gerçekten harikasınız sorumu yazdıktan sonra değişiklik yaptım ama 2 cevap birden gelmişti bile gerçekten tskler ama soruyu eksik sormuşum onu düzelttim bulunan satırın a:an aralığını kopyalamak istiyorum
Sheets("sayfa2").Cells(c, 1) = Sheets("sayfa1").Cells(a, 1).Value
Sheets("sayfa2").Cells(c, 2) = Sheets("sayfa1").Cells(a, 2).Value
Sheets("sayfa2").Cells(c, 3) = Sheets("sayfa1").Cells(a, 3).Value
Sheets("sayfa2").Cells(c, 4) = Sheets("sayfa1").Cells(a, 4).Value
Sheets("sayfa2").Cells(c, 5) = Sheets("sayfa1").Cells(a, 5).Value
bu şekilde yapayım dedim biraz uzun sürüyor
saygılar
Bu durumda copy-paste en kısa yol galiba aşağıdaki gibi deneyin.
[vb:1:9b97849a4a]Application.ScreenUpdating = False
c = 0
For a = 1 To 100
If Sheets("sayfa1").Cells(a, 1).Interior.ColorIndex = 6 Then
sat = Sheets("sayfa1").Cells(a, 1).Row
Sheets("sayfa1").Rows(sat).Copy
c = c + 1
Sheets("sayfa2").Cells(c, 1).PasteSpecial Paste:=xlValues
End If
Next a
Application.CutCopyMode = False[/vb:1:9b97849a4a]
[vb:1:10c4820996]Sub Test2()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim MyRng As Range
Dim Nrow As Long
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Sh2.Range("A1:A" & Sh2.Range("A65536").End(xlUp).Row).Clear
For Each MyRng In Sh1.Range("A1:A100")
If MyRng.Interior.ColorIndex = 6 Then
Nrow = Sh2.Range("A65536").End(xlUp).Row + 1
Sh1.Rows(MyRng.Row).Copy
Sh2.Range("A" & Nrow).PasteSpecial
End If
Next
Application.CutCopyMode = False
Range("A1").Select
End Sub
[/vb:1:10c4820996]
Edit:
Bu kez de ben görmedim....
Levent - Raider : 1 -1 (Maçın skoru) :mrgreen:
Sizlere daha iyi bir deneyim sunabilmek icin sitemizde çerez konumlandırmaktayız, web sitemizi kullanmaya devam ettiğinizde çerezler ile toplanan kişisel verileriniz Veri Politikamız / Bilgilendirmelerimizde belirtilen amaçlar ve yöntemlerle mevzuatına uygun olarak kullanılacaktır.