• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Pivot Table'ı Hücredeki Veri Doğrulama İle Listelemek

B

Believing

Altın Üye
Katılım
19 Mayıs 2013
Mesajlar
703
Excel Vers. ve Dili
Office Pro 2019 TR 32 Bit
Windows Pro 10 TR 64 Bit
Sayın Uzman arkadaşlar,

Ekteki çalışmadaki PivotTable çalışmasında listelemeyi bir hücreye atamak ve buradan yönetmek istiyorum.
Pivot Table "ÖZET" isimli sayfasının "B7" hücresinden itibaren başlıyor ve "satır etiketleri" filtresi "B7" hücresinde bulunuyor.
Buna göre, "B3" hücresindeki veri doğrulama ile seçim yaptığımda, seçimi satır etiketlerindeki filtreye uygulasın. Yani sadece "B3" hücresindeki seçime göre özet tablo listelensin ve seçim haricindekiler gözükmesin.
Bu senaryoyu gerçekleştiremedim. Acaba bu senaryo için nasıl bir kod düzenlemeliyim?

Saygılarımla,
 

Ekli dosyalar

Deneyiniz.

ÖZET isimli sayfanızın kod bölümüne uygulayınız.

C++: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Call Ozet_Tabloya_Filtre_Uygula
    Application.EnableEvents = True
End Sub

Boş bir modüle aşağıdaki kodu uygulayınız.

C++: 
Option Explicit

Sub Ozet_Tabloya_Filtre_Uygula()
    Dim Kriter As PivotItem
    
    Application.ScreenUpdating = False
    
    With Sheets("ÖZET")
        On Error GoTo Son
        .PivotTables("PivotTable1").PivotFields("REGION").ClearAllFilters
        For Each Kriter In .PivotTables("PivotTable1").PivotFields("REGION").PivotItems
            If Kriter <> .Range("B3").Value Then
                Kriter.Visible = False
            End If
        Next
    End With

    Application.ScreenUpdating = True
    Exit Sub
    
Son: MsgBox "Lütfen uygun filtre kriteri seçiniz!", vbExclamation
End Sub

Sonra B3 hücresini değiştirip deneyiniz.
 
Sayın Korhan bey,

Tek kelime ile kusursuz, mükemmel çalışıyor. Ellerinize ve emeğinize sağlık.
ALLAH sizden ve sevdiklerinizden razı olsun.
Hakkınız üzerime olduk fazla geçmektedir. Lütfen haklarınızı helal ediniz.
Hayırlı akşamlar.

Saygılarımla,
 
Sayın Korhan bey,

Affınıza sığınarak son bir soru daha sormak durumundayım. Zira kurguladığım senaryoyu sonlandıramıyorum.
Aslında 1. mesajdaki "ÖZET" isimli sayfayı şablon sayfa olarak kullanıyorum.
Yeni çalışmaya eklediğim "SETTINGS" isimli sayfadaki butona basarak, "ÖZET" sayfasının kopyalarını oluşturuyorum.
Sayfaları oluştururken isimlerini "PARAMETRE" sayfasındaki "S3:S50" aralığından almasını sağlıyorum.
Sayfa isimlerini oluşturulan sayfalardaki veri doğrulamanın bulunduğu "B" hücresine formül ile yazdırıyorum.
Yukarıdaki koşullara göre oluşturulan sayfalardaki PivotTable verilerinin otomatik güncellenmesini sağlayamıyorum.
Bu konuda benim için çok değerli olan yardımlarınızı tekrar rica ediyorum.

Saygılarımla,
 

Ekli dosyalar

Sayın Korhan bey,

ALLAH sizden ve sevdiklerinizden razı olsun.
Lütfen haklarınızı helal ediniz.
Kolay gelsin.

Saygılarımla,
 
Korhan Ayhan' Alıntı:
Hakkım varsa helal olsun..
Genişletmek için tıkla ...

Sayın Korhan bey,

Yukarıdaki kodlarınızı kendi çalışmalarıma uyguladığımda çoğaltılan sayfalardaki Pivot Table'lar güncel isimler ile açılmıyor.
Konuyu biraz açar mısınız? öğrenmek adına.

Saygılarımla
 
ÖZET isimli sayfanın kod bölümünde kodlar var. Bunu kendin orjinal dosyanızda uyguladınız mı?

Ayrıca Module1 ve Modul2 içinde kodlar var. Bunları da asıl dosyanıza almalısınız.

Bunun dışında başka özel bir işlem yoktur. Doğru uygularsanız çalışmaması için bir engel göremiyorum.
 
Veri doğrulama secimini degistirdigimde(E1:F1) başka sayfadaki pivotlari otomatik guncelleme makrosu nasıl yapılır?
 
Bu makroyu yazdim ama calismiyor
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range

' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("E1:F1")

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then

' Display a message when one of the designated cells has been
' changed.


Sheets("Özet").Select
Range("A15").Select
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
Range("E15").Select
ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
Range("H15").Select
ActiveSheet.PivotTables("PivotTable4").PivotCache.Refresh
Range("K15").Select
ActiveSheet.PivotTables("PivotTable5").PivotCache.Refresh
Range("N15").Select
ActiveSheet.PivotTables("PivotTable6").PivotCache.Refresh
ActiveWindow.SmallScroll ToRight:=9
Range("Q15").Select
ActiveSheet.PivotTables("PivotTable7").PivotCache.Refresh
Range("T15").Select
ActiveSheet.PivotTables("PivotTable8").PivotCache.Refresh
ActiveWindow.SmallScroll ToRight:=2
Sheets("REM").Select
Range("I1").Select

MsgBox "E1:F1 " & Dönem.Değişti & " değişti. "

End If
End Sub
 
Deneyiniz.

C++: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet, PT As PivotTable
    
    If Intersect(Target, Range("E1:F1")) Is Nothing Then Exit Sub
    
    For Each WS In ThisWorkbook.Worksheets
        For Each PT In WS.PivotTables
            PT.RefreshTable
        Next PT
    Next WS

    MsgBox "Özet tablolar güncellenmiştir.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Deneyiniz.

ÖZET isimli sayfanızın kod bölümüne uygulayınız.

C++: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Call Ozet_Tabloya_Filtre_Uygula
    Application.EnableEvents = True
End Sub

Boş bir modüle aşağıdaki kodu uygulayınız.

C++: 
Option Explicit

Sub Ozet_Tabloya_Filtre_Uygula()
    Dim Kriter As PivotItem
 
    Application.ScreenUpdating = False
 
    With Sheets("ÖZET")
        On Error GoTo Son
        .PivotTables("PivotTable1").PivotFields("REGION").ClearAllFilters
        For Each Kriter In .PivotTables("PivotTable1").PivotFields("REGION").PivotItems
            If Kriter <> .Range("B3").Value Then
                Kriter.Visible = False
            End If
        Next
    End With

    Application.ScreenUpdating = True
    Exit Sub
 
Son: MsgBox "Lütfen uygun filtre kriteri seçiniz!", vbExclamation
End Sub

Sonra B3 hücresini değiştirip deneyiniz.
Genişletmek için tıkla ...
Korhan Ayhan' Alıntı:
Deneyiniz.

ÖZET isimli sayfanızın kod bölümüne uygulayınız.

C++: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B3")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Call Ozet_Tabloya_Filtre_Uygula
    Application.EnableEvents = True
End Sub

Boş bir modüle aşağıdaki kodu uygulayınız.

C++: 
Option Explicit

Sub Ozet_Tabloya_Filtre_Uygula()
    Dim Kriter As PivotItem
  
    Application.ScreenUpdating = False
  
    With Sheets("ÖZET")
        On Error GoTo Son
        .PivotTables("PivotTable1").PivotFields("REGION").ClearAllFilters
        For Each Kriter In .PivotTables("PivotTable1").PivotFields("REGION").PivotItems
            If Kriter <> .Range("B3").Value Then
                Kriter.Visible = False
            End If
        Next
    End With

    Application.ScreenUpdating = True
    Exit Sub
  
Son: MsgBox "Lütfen uygun filtre kriteri seçiniz!", vbExclamation
End Sub

Sonra B3 hücresini değiştirip deneyiniz.
Genişletmek için tıkla ...
Merhaba, hala formda mısınız bilmiyorum ama şansımı denemek istedim. Eğer hiç seç
Nadir4606' Alıntı:
Teşekkür ederim..
Genişletmek için tıkla ...
Ankcak bir soru eklemek istiyorum, bu kodlarla sadece her seferinde makroyu manuel çalıştırmak zorunda kalıyorum. Ben hücrede değişiklik olduğunda pivotta da değişiklik olsun istiyorum. Ama onu da ayrı bir kodla mı yazmak gerekiyor bilmiyorum. Teşekkür ederim
 
Merhaba,

Makro ÖZET sayfasında B3 hücresini elle değiştirdiğinizde devreye girmektedir.
 
Nadir4606' Alıntı:
Teşekkür ederim..
Genişletmek için tıkla ...
Saygıdeğer hocam, daha önce paylaşmış olduğunuz filtreleme makrosunu uygulamak istedim ancak benim hatam olsa gerek sağlıklı çalışmadı.
Deneyerek ilgili hücrede değişiklik yaptı ancak çoklu seçim yaptığı için ve filtreyi temizlemediği için olsa gerek çok öge seçimi yaptığından verilerimi alamadım.
bu konuda ne yapabiliriz..
Yardımcı olursanız sevinirim.
 
Örnek dosyanızı paylaşırsanız ona göre çözümler üretilebilir..
 
Harici dosya barındırma sitelerine örnek dosyanızı yükleyip forumda paylaşabilirsiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst