Şartlı veri süzme

[oburs]

iyi çalışmalar herkese..
isteğim şu şekilde..
KOŞULLAR
A1=ADANA
B1=TURUNÇGİL
C1=PORTAKAL
D1>= '01.01.2011'
E1<= '31.01.2011'

Vermiş olduğum koşullarda sayfa1'den verileri süzecek ve A7 hücresine sayfa1'deki başlıkları değiştirmeden sayfa2'ye verilen koşullar nisbetinde süzerek getirecek..
yardımlarınız için şimdiden teşekkürler..

 

[asi_kral]

Dosya var mı_?

 

[oburs]

Dosyayı ekledim..

 

[asi_kral]

Dosyayı ekledim..

Merhaba
Boş bir module kopyalayın ve deneyin.

------------------------------------


Option Explicit
Sub süz_aktar_1967()
'Konu : Açıklamalara Göre Süz ve Aktar
'Coder By : asi_kral_1967
Dim asi, kral
Dim a, b
Set asi = Sheets("Sayfa1")
Set kral = Sheets("Sayfa2")
kral.Select
Range("A8:E" & Rows.Count).ClearContents
a = ActiveCell.Address
b = asi.Range("A" & Rows.Count).End(xlUp).Row
asi.Range("A1:E" & b).AutoFilter field:=1, Criteria1:=kral.Range("A2")
asi.Range("A1:E" & b).AutoFilter field:=2, Criteria1:=kral.Range("B2")
asi.Range("A1:E" & b).AutoFilter field:=3, Criteria1:=kral.Range("C2")
asi.Range("A1:E" & b).AutoFilter field:=4, Criteria1:=CDate(kral.Range("D2"))
asi.Range("A1:E" & b).AutoFilter field:=5, Criteria1:=CDate(kral.Range("E2"))
asi.Range("A2:E" & b).Copy
kral.Range("A8").PasteSpecial (xlPasteValues)
asi.Range("A1:E" & b).AutoFilter
Range(a).Select
MsgBox "İşlem Tamam", vbInformation, "asi_kral_1967"
End Sub

--------------------------------------

Dosyanız ekte

 

[oburs]

Elinize Sağlık

Elinize sağlık fakat süzme islemini yapmamakta..bir yanlışlıkmı yapıyorum acaba ..
kontrol edebilrimisiniz..

 

[asi_kral]

Elinize sağlık fakat süzme islemini yapmamakta..bir yanlışlıkmı yapıyorum acaba ..
kontrol edebilrimisiniz..

Anlayamadım ne yapmıyor.
İstediğiniz sayfaya gelmiyor mu bilgiler.
Yada tam olarak ne istediğinizi örnekleyerek anlatırsanız daha iyi olur bizde anlarız.

 

[oburs]

Bilgi..

Geliyor fakat benim sayfa2 de ki hücrelerde belirtmiş olduğum kriterlere göre sort etmesini istemekteyim..makroyu çalıştırdığımda tüm liste gelmekte..
örnek olarak a2+b2+c2+d2+e2 hücrelerine yazmış olduklarıma göre filtre yapıp a8 hücresine şartlara uyanları listlenemsini istemekteyim..

 

[asi_kral]

Geliyor fakat benim sayfa2 de ki hücrelerde belirtmiş olduğum kriterlere göre sort etmesini istemekteyim..makroyu çalıştırdığımda tüm liste gelmekte..
örnek olarak a2+b2+c2+d2+e2 hücrelerine yazmış olduklarıma göre filtre yapıp a8 hücresine şartlara uyanları listlenemsini istemekteyim..

Süzme yaptığınızda kalan verileri getiriyor.
Buyrun kodda ufak bir değişiklik yaptım.
Dosya ekte

 

[oburs]

üstadım.kusura bakmayın dosyayı ekledim.

 

[asi_kral]

üstadım..bu sefer hiçbir şey getirmiyor..

Dosyanızı ekler misiniz_?

 

[oburs]

İlgili dosya eklenmiştir..

iligli dosya eklenmiştir..
Dosyada herhangi bir değişiklik yapmadım..

 

[asi_kral]

iligli dosya eklenmiştir..
Dosyada herhangi bir değişiklik yapmadım..

Sanırım yanlış oldu resim yüklemişsiniz_?

 

[oburs]

Kusura bakmayın ilgili dosyayı ekledim..

 

[asi_kral]

Kusura bakmayın ilgili dosyayı ekledim..

Sanırım gene anlaşamadık.
Şimdi sizin istediğiniz şu değil mi_?
Sayfa2'nin A2 - B2 - C2 - D2 - E2 verilerine göre
Sayfa1'de süzülsün kalanları A8'den itibaren getirsin istemiyor musunuz_?
Yoksa ben mi yanlış anlıyorum.
Çünkü bu kod bu istediğinizi yapıyor.

 

[oburs]

evet

evet aynen istediğim bu şekilde..yani yukarıda vermiş olduğum filtreye uygun olan ları listelemesi ama.. makro çalışınca boş olarak geliyor..

 

[asi_kral]

evet aynen istediğim bu şekilde..yani yukarıda vermiş olduğum filtreye uygun olan ları listelemesi ama.. makro çalışınca boş olarak geliyor..

Bulduğu veriyi
A8 hücresine yapıştırıyor. Dilerseniz A8:E8 hücrelerini temizleyin ve makroyu çalıştırın.
Ben de normal şekilde çalışıyor. Çünkü verdiğiniz kriterlere göre sadece 1 tane veri var ve onu buluyor ve sayfa2'ye taşıyor.

 

[asi_kral]

Merhaba
Bu kodu dener misiniz_?

-------------------------


Option Explicit
Sub süz_aktar_1967()
'Konu : Açıklamalara Göre Süz ve Aktar
'Mail : asi_kral_1967@gmail.com
'Coder By : asi_kral_1967
Dim asi, kral
Dim a, b
Set asi = Sheets("Sayfa1")
Set kral = Sheets("Sayfa2")
kral.Select
Range("A8:E" & Rows.Count).ClearContents
a = ActiveCell.Address
b = asi.Range("A" & Rows.Count).End(xlUp).Row
asi.Range("A1:E" & b).AutoFilter field:=1, Criteria1:=kral.Range("A2")
asi.Range("A1:E" & b).AutoFilter field:=2, Criteria1:=kral.Range("B2")
asi.Range("A1:E" & b).AutoFilter field:=3, Criteria1:=kral.Range("C2")
asi.Range("A1:E" & b).AutoFilter field:=4, Criteria1:=CStr(kral.Range("D2"))
asi.Range("A1:E" & b).AutoFilter field:=5, Criteria1:=CStr(kral.Range("E2"))
If WorksheetFunction.Subtotal(3, asi.Range("A2:A" & b)) > 0 Then
asi.Range("A2:E" & b).Copy
kral.Range("A8").PasteSpecial (xlPasteValues)
End If
asi.Range("A1:E" & b).AutoFilter
Range(a).Select
MsgBox "İşlem Tamam", vbInformation, "asi_kral_1967"
End Sub

-------------------------------

 

[Korhan Ayhan]

Merhaba,

Arkadaşlar kod önerilerinizi foruma eklerken lütfen aşağıdaki tag arasına yazın.

[ CODE ] ....... [ /CODE ]

Not: Siz boşlukları kaldırarak tagı kullanın.

 

[asi_kral]

Merhaba,

Arkadaşlar kod önerilerinizi foruma eklerken lütfen aşağıdaki tag arasına yazın.

[ CODE ] ....... [ /CODE ]

Not: Siz boşlukları kaldırarak tagı kullanın.

Hocam bu tag'ın bir kısa yolu var mı_?

 

[Korhan Ayhan]

Merhaba,

Eğer konuya yanıt verirken "CEVAP YAZ" butonu ile yanıtlarsanız karşınıza gelen penceredeki menüde "#" işareti olarak bir kısayolu var.

Ya da "HIZLI CEVAP" penceresininin altındaki "GELİŞMİŞ MODA DÖN" butonuna tıklarsanız yine aynı pencereye ulaşabilirsiniz.