koşula uyan satır

[sekand]

selamlar
sayfa1 a1:a100 arasında dolgu rengi sarı olan hücre varsa o satırın a:an aralığını sayfa2 ye nasıl kopyalarız

 

[Haluk]

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]

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyiniz.

[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]

Düzeltme:Sn Raider'in mesajını görmemiştim.

 

[sekand]

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

 

[Levent Menteşoğlu]

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]

 

[Haluk]

[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:

 

[sekand]

yardımlarınız için tskler
tek kelimeyle harikasınız