Renkli Hücreleri Kopyalama

[SER973]

Satırlardaki Renkli Hücreler Sayılıp; İstenilen Sayıya eşit olan satırları kopyalayıp ayrı bir yere yapıştırmak için yardımlarınızı bekliyorum...

Örnek Dosya Ektedir....

 

[Ayhan Ercan]

Merhaba

Şöyle üstünkörü bişey yapmaya çalıştım. Ek dosyayı inceleyiniz...

Private Sub CommandButton1_Click()
Range("A9:I10").ClearContents
Range("A9:I10").Interior.ColorIndex = xlNone
For i = 17 To 27
    For Each say In Range(Cells(i, 2), Cells(i, 9))
        If say.Interior.ColorIndex = 4 Then
            sayac = sayac + 1
        End If
    Next
    If sayac = [d2].Value Then
        [a9].Activate
        If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Activate
        Range(Cells(i, 1), Cells(i, 9)).Copy _
        Range(ActiveCell.Address(0, 0), ActiveCell.Offset(0, 8).Address(0, 0))
    Else: GoTo 10
    End If
10     sayac = 0
Next i
End Sub

 

[SER973]

Teşekkür

Sn Ayhan Ercan Yardımlarınız için çok teşekkürler...
Elinize sağlık