Hücre Değerine Göre Satır Kopyalama

[leonadies]

Arkadaşlar A sütununda var olan karışık verilerden sadece "METAL" yazanları ve bu satırın tamamını başka bir sekmeye yazdırmanın yolu var mıdır? Gelişmiş filtreleme işimi görmüyor malesef.. çok denedim.

 

[Orion1]

Otomatik filtre kullanmayı deneyin.

 

[leonadies]

Hocam otomatik filtreden kastın Gelişmiş filtre ise şayet; onda şöyle bir problem yaşanıyor.1.Sekmedeki "METAL" içeren hücrelere yenisi eklenince 2.Sekmede yer alan bu filtreleme düzenide otomatikmen bozuluyor.Bunun olması engellenmiyor. Kullanıcıdan 1.sekmeyi gizlemeliyim. 2Sekmede sadece "metal" yazan filtrelenmiş olmalı araya boşluk vb hücreler girmemeli yani..

 

[leonadies]

Yardımlarınızı beklemekteyim...

 

[ÖmerBey]

Aşağıdaki kodu kendinize göre uyarlayıp deneyiniz.

Sub KOD()
Set s1 = Sheets("[COLOR="Red"]Sayfa1[/COLOR]") 'Verilerin olduğu sayfa
Set s2 = Sheets("[COLOR="red"]Sayfa2[/COLOR]") 'Aktarılacak sayfa
For a = 1 To s1.Range("A65500").End(3).Row
    If s1.Cells(a, "A") = "[COLOR="red"]METAL[/COLOR]" Then
        x = x + 1
        For b = 1 To s1.UsedRange.Columns.Count
            s2.Cells(x, b) = s1.Cells(a, b)
        Next
    End If
Next
End Sub

Not: Sorularınızı örnek dosya ile somutlaştırırsanız daha net yardımlar alırsınız.

 

[Orion1]

Hocam otomatik filtreden kastın Gelişmiş filtre ise şayet; onda şöyle bir problem yaşanıyor.1.Sekmedeki "METAL" içeren hücrelere yenisi eklenince 2.Sekmede yer alan bu filtreleme düzenide otomatikmen bozuluyor.Bunun olması engellenmiyor. Kullanıcıdan 1.sekmeyi gizlemeliyim. 2Sekmede sadece "metal" yazan filtrelenmiş olmalı araya boşluk vb hücreler girmemeli yani..

Gelişmiş filtre değil.
Otomatik filtre.

 

[hturkavci03]

Merhaba, aynı sorunun biraz gelişmiş haline çare arıyorum. Verdiğiniz kodu

Sub KOD()
Set s1 = Sheets("Sayfa1") 'Verilerin olduğu sayfa
Set s2 = Sheets("Sayfa2") 'Aktarılacak sayfa
Set s3 = Sheets("Sayfa3") 'Aktarılacak sayfa
For a = 1 To s1.Range("A65500").End(3).Row
If s1.Cells(a, "A") = "METAL" Then
x = x + 1
For b = 1 To s1.UsedRange.Columns.Count
s2.Cells(x, b) = s1.Cells(a, b)
Next
End If
If s1.Cells(a, "A") = "AĞAÇ" Then
x = x + 1
For b = 1 To s1.UsedRange.Columns.Count
s3.Cells(x, b) = s1.Cells(a, b)
Next
End If
Next

End Sub

şeklinde uyguladım ve sorunsuz kopyalama yapıyor ancak kopyalama sonuçlarında aralarda satır boşlukları oluşuyor. Bu boşlukları nasıl engelleriz.