makro ile otomatik filtre yapıp aktarma

[isteobenim]

Merhabalar,

Ekte görüldüğü gibi verilerin tek tek süzülerek süzülen toplam miktarı ve kalem sayısını bularak A1:W20 arasındaki muhtelif hücrelere aktarmak istiyorum.

Örnek B sütununda iki secenek var Artı ve Eksi önce Artı olarak filtreleyip sırasıyla C , D ve E sütunarınıdaki değerleride sırasıyla filtreleyerek A sütununda çıkacak sonucun toplam ve satır sayısını bularak değişik hücrelere yazdırmak.

Bu veriler min.25000 satır olacak ve başka bir sayfadan formüle edilerek alınıyor.Ben bunu tek tek makro kaydederek yaptım ancak çok ağır çalışıyor.Bu nedenle forumda araştırdım, döngü kullanarak daha hızlı yapılabilir gibi görünüyor ancak bu şekilde döngü kurrmayı bir türlü çözemedim.

Bu işlemi daha kısa kod ve hızlı şekilde yapabilecek arkadaşlardan yardım rica ediyorum.

Teşekkürler,

 

[halit3]

Merhabalar,

Ekte görüldüğü gibi verilerin tek tek süzülerek süzülen toplam miktarı ve kalem sayısını bularak A1:W20 arasındaki muhtelif hücrelere aktarmak istiyorum.

Örnek B sütununda iki secenek var Artı ve Eksi önce Artı olarak filtreleyip sırasıyla C , D ve E sütunarınıdaki değerleride sırasıyla filtreleyerek A sütununda çıkacak sonucun toplam ve satır sayısını bularak değişik hücrelere yazdırmak.

Bu veriler min.25000 satır olacak ve başka bir sayfadan formüle edilerek alınıyor.Ben bunu tek tek makro kaydederek yaptım ancak çok ağır çalışıyor.Bu nedenle forumda araştırdım, döngü kullanarak daha hızlı yapılabilir gibi görünüyor ancak bu şekilde döngü kurrmayı bir türlü çözemedim.

Bu işlemi daha kısa kod ve hızlı şekilde yapabilecek arkadaşlardan yardım rica ediyorum.

Teşekkürler,

ekli dosyaya bir bakarmısınız

 

[isteobenim]

hocam ilgin için teşekkür ederim ancak istediğim bu değildi.
ben sadece süzülen alttoplam miktarını,sonucunu (alttoplam formülü yazılı bir hücredende olabilir)
alıp aynı sayfada A1 A4 B8 C6 gibi sabit olarak 40 kadar değişik hücreye kopyalamak olacak.
yani veri tablosundan süzülerek bulanan sonuç sabit olarak bir tabloya (çizelgeye) aktarılacak.
not: özet tablo ile yapılacak bir işlem olamıyor.çünkü süzülen veriler başka bir yerden formüle edilerek alınıyor.

 

[isteobenim]

ve ilave olarak bütün bu işlemler tek makro ile yapılacak yani raporu çalıştır denildiğinde özet tablo misali bütün değerler filtrelenip sonuclar ayrı ayrı belirlenecek hücrelere aktarılacak.

 

[Korhan Ayhan]

Selamlar,

Hangi bilgiler hangi hücrelere hangi şarta göre yazılacak? Bu detayları verirseniz kodu düzenlemek daha kolay olacaktır.

 

[isteobenim]

Merhaba,

Kusurabakmayın ben anlatamıyorum galiba, özürdilerim,
B,C,D ve E sutunundaki veriler sırasıyla tek tek süzülerek A sutunundaki değerlerin toplamını ki ben bunu ALTTOPLAM formulüyle yapıyorum.Bu sonucları (her sütundaki kritere göre süz işlemi yapılınca tek tek)kopyalayıp (sonuc aynı sayfadaki herhangi bir hücrede olabilir) yine aynı sayfada A1 B1 C1 D1 şeklinde sırasıyla hücrelere aktarmak.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz. Süzülen verilerin değerlerini K-P sütunlarına listeler. Listeleme işlemini yaparken TOPLAM değeri sıfıra eşit olmayanlar listelenir.


Kullanılan kod;

Option Explicit
 
Sub ÖZET_TABLO()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X1 As Long, X2 As Long, X3 As Long, X4 As Long, Satır As Long
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
 
    Application.ScreenUpdating = False
 
    S1.Range("K2:P65536").ClearContents
    S2.Range("A:D").ClearContents
 
    S1.Range("B14:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S2.Range("A1"), Unique:=True
    S1.Range("C14:C65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S2.Range("B1"), Unique:=True
    S1.Range("D14:D65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S2.Range("C1"), Unique:=True
    S1.Range("E14:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S2.Range("D1"), Unique:=True
 
    Satır = 2
 
    For X1 = 2 To S2.Range("A65536").End(3).Row
        If S2.Cells(X1, 1) <> "" Then
        S1.Range("A14").AutoFilter Field:=2, Criteria1:=S2.Cells(X1, 1)
 
            For X2 = 2 To S2.Range("B65536").End(3).Row
                If S2.Cells(X2, 2) <> "" Then
                S1.Range("A14").AutoFilter Field:=3, Criteria1:=S2.Cells(X2, 2)
                    For X3 = 2 To S2.Range("C65536").End(3).Row
                        If S2.Cells(X3, 3) <> "" Then
                        S1.Range("A14").AutoFilter Field:=4, Criteria1:=S2.Cells(X3, 3)
                            For X4 = 2 To S2.Range("D65536").End(3).Row
                                If S2.Cells(X4, 4) <> "" Then
                                S1.Range("A14").AutoFilter Field:=5, Criteria1:=S2.Cells(X4, 4)
 
                                    If S1.Range("C8") <> 0 Then
                                        S1.Cells(Satır, "K") = S2.Cells(X1, 1)
                                        S1.Cells(Satır, "L") = S2.Cells(X2, 2)
                                        S1.Cells(Satır, "M") = S2.Cells(X3, 3)
                                        S1.Cells(Satır, "N") = S2.Cells(X4, 4)
                                        S1.Cells(Satır, "O") = S1.Range("C8")
                                        S1.Cells(Satır, "P") = S1.Range("C9")
                                        Satır = Satır + 1
                                    End If
 
                                End If
                            Next
 
                        End If
                    Next
 
                End If
            Next
 
        End If
    Next
 
    S1.Range("A14").AutoFilter
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub