kritere uyan satırları alt alta sıralama

[haso_excel]

Merhaba arkadaşlar,
Database adında bır sayfamda, her satır için kolon bazında sarı renk kontrolu yapıp, o satırda 1 ve birden fazla sarı varsa istenen adlı sayfaya kritere uyan satırları alt alta sırlamasını istiyorum.Öenek dosya ekde

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub renklilistele()
Set s1 = Sheets("database")
Set s2 = Sheets("istenen")
For a = 2 To s1.[a65536].End(3).Row
If s1.Cells(a, "h").Interior.ColorIndex = 6 Then
sat = s2.[a65536].End(3).Row + 1
s1.Rows(a).Copy s2.Rows(sat)
End If
Next
End Sub

 

[haso_excel]

Teşekkürler Levent bey,
İşlem tamam

 

[haso_excel]

Levent bey, kontrolüm sırasında şöyle bir şey farkettim. Eğer farklı bir sütünda sarı onu diğer sayfaya almıyor. Aslında ilgili database de sarı renk hangi hücrede olursa olusun (b2 ile satır ve kolon sayısı belli olmayan bir aralıkta sarı renk kontrolü yapılacak alan) sarı renk olan hücreleri sırasıyla ilgili sayfaya aktaracak. Dosyam ekde ilginiz için teşekkürler

 

[haso_excel]

Arkadaşlar,
Levent beyin kodunda database sayfasında, b2 ile satır ve kolon sayısı belli olmayan bir aralıkta sarı renk kontrolü yapmak için değişiklik yaptım fakat olmadı yardımcı olur musunuz lütfen ?

Sub renklilistele()
Set s1 = Sheets("database")
Set s2 = Sheets("ıstenen")
For a = 2 To s1.[a65536].End(1).Column
If s1.Cells(2, a).Interior.ColorIndex = 6 Then
sat = s2.[a65536].End(3).Row + 1
s1.Rows(a).Copy s2.Rows(sat)
End If
Next
Rows("1:1").Select
Selection.Copy
Sheets("ıstenen").Select
Rows("1:1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:A").EntireColumn.AutoFit
Range("B2").Select
MsgBox "İŞLEM TAMAM"
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub renklilistele()
Set s1 = Sheets("database")
Set s2 = Sheets("ıstenen")
Application.FindFormat.Interior.ColorIndex = 6
For a = 2 To s1.[a65536].End(3).Row
If Not Rows(a).Find(What:="", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True) Is Nothing Then
sat = s2.[a65536].End(3).Row + 1
s1.Rows(a).Copy s2.Rows(sat)
End If
Next
Application.FindFormat.Clear
MsgBox "İŞLEM TAMAM"
End Sub

 

[haso_excel]

Teşekkürler Levent bey,
İstedğim tam olarak buydu.