Note: The other languages of the website are Google-translated. Back to English

Πώς να συνδέσετε το φίλτρο συγκεντρωτικού πίνακα σε ένα συγκεκριμένο κελί στο Excel;

Εάν θέλετε να συνδέσετε ένα φίλτρο Συγκεντρωτικού πίνακα με ένα συγκεκριμένο κελί και να κάνετε το Συγκεντρωτικό πίνακα φιλτραρισμένο με βάση την τιμή κελιού, η μέθοδος σε αυτό το άρθρο μπορεί να σας βοηθήσει.

Συνδέστε το φίλτρο Pivot Table σε ένα συγκεκριμένο κελί με κωδικό VBA


Συνδέστε το φίλτρο Pivot Table σε ένα συγκεκριμένο κελί με κωδικό VBA

Ο Συγκεντρωτικός Πίνακας που θα συνδέσετε τη λειτουργία φίλτρου με μια τιμή κελιού θα πρέπει να περιλαμβάνει ένα πεδίο φίλτρου (το όνομα του πεδίου φίλτρου διαδραματίζει σημαντικό ρόλο στον ακόλουθο κώδικα VBA).

Για παράδειγμα, πάρτε τον παρακάτω Συγκεντρωτικό Πίνακα, το πεδίο φίλτρου στον Συγκεντρωτικό πίνακα καλείται Κατηγορίακαι περιλαμβάνει δύο τιμές "Εξοδα"Και"Πωλήσεις". Αφού συνδέσετε το φίλτρο Συγκεντρωτικού πίνακα σε ένα κελί, οι τιμές κελιών που θα εφαρμόσετε στο φίλτρο Συγκεντρωτικός πίνακας θα πρέπει να είναι «Έξοδα» και «Πωλήσεις».

1. Επιλέξτε το κελί (εδώ επιλέγω το κελί H6) που θα συνδέσετε με τη λειτουργία φίλτρου του Συγκεντρωτικού Πίνακα και εισαγάγετε μία από τις τιμές φίλτρου στο κελί εκ των προτέρων.

2. Ανοίξτε το φύλλο εργασίας περιέχει τον Συγκεντρωτικό Πίνακα που θα συνδέσετε με το κελί. Κάντε δεξί κλικ στην καρτέλα φύλλων και επιλέξτε Προβολή κωδικού από το μενού περιβάλλοντος. Δείτε το στιγμιότυπο οθόνης:

3. Στο Microsoft Visual Basic για εφαρμογές παράθυρο, αντιγράψτε κάτω από τον κώδικα VBA στο παράθυρο Code.

Κωδικός VBA: Σύνδεση φίλτρου συγκεντρωτικού πίνακα σε ένα συγκεκριμένο κελί

Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180702
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xStr As String
    On Error Resume Next
    If Intersect(Target, Range("H6")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Sheet1").PivotTables("PivotTable2")
    Set xPFile = xPTable.PivotFields("Category")
    xStr = Target.Text
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True
End Sub

Notes:

1) "Sheet1Είναι το όνομα του ανοιχτού φύλλου εργασίας.
2) "Συγκεντρωτικός πίνακας2"Είναι το όνομα του Συγκεντρωτικού Πίνακα που θα συνδέσετε τη λειτουργία φίλτρου με ένα κελί.
3) Το πεδίο φιλτραρίσματος στον συγκεντρωτικό πίνακα ονομάζεται "Κατηγορία".
4) Το κελί αναφοράς είναι H6. Μπορείτε να αλλάξετε αυτές τις μεταβλητές τιμές με βάση τις ανάγκες σας.

4. Πάτα το άλλος + Q πλήκτρα για να κλείσετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

Τώρα η λειτουργία φίλτρου του Συγκεντρωτικού Πίνακα συνδέεται με το κελί H6.

Ανανεώστε το κελί H6 και, στη συνέχεια, τα αντίστοιχα δεδομένα στο Συγκεντρωτικό πίνακα φιλτράρονται με βάση την υπάρχουσα τιμή. Δείτε το στιγμιότυπο οθόνης:

Όταν αλλάζετε την τιμή κελιού, τα φιλτραρισμένα δεδομένα στον Συγκεντρωτικό Πίνακα θα αλλάξουν αυτόματα. Δείτε το στιγμιότυπο οθόνης:


Επιλέξτε εύκολα ολόκληρες σειρές με βάση την τιμή κελιού σε μια στήλη πιστοποιητικού:

Η καλύτερη Επιλέξτε συγκεκριμένα κελιά χρησιμότητα του Kutools για Excel μπορεί να σας βοηθήσει να επιλέξετε γρήγορα ολόκληρες σειρές με βάση την τιμή κελιού σε μια στήλη πιστοποιητικού στο Excel όπως φαίνεται παρακάτω το στιγμιότυπο οθόνης. Αφού επιλέξετε όλες τις σειρές με βάση την τιμή κελιού, μπορείτε να τις μετακινήσετε ή να τις αντιγράψετε με μη αυτόματο τρόπο σε μια νέα τοποθεσία όπως χρειάζεστε στο Excel.
Κατεβάστε και δοκιμάστε το τώρα! (30- ημέρα δωρεάν διαδρομή)


Σχετικά άρθρα:


Τα καλύτερα εργαλεία παραγωγικότητας του Office

Το Kutools για Excel λύνει τα περισσότερα από τα προβλήματά σας και αυξάνει την παραγωγικότητά σας κατά 80%

  • Επαναχρησιμοποίηση: Εισαγάγετε γρήγορα σύνθετοι τύποι, γραφήματα και οτιδήποτε έχετε χρησιμοποιήσει στο παρελθόν. Κρυπτογράφηση κυττάρων με κωδικό πρόσβασης Δημιουργία λίστας αλληλογραφίας και στείλτε email ...
  • Super Formula Bar (επεξεργαστείτε εύκολα πολλές γραμμές κειμένου και τύπου). Διάταξη ανάγνωσης (εύκολη ανάγνωση και επεξεργασία μεγάλου αριθμού κελιών). Επικόλληση σε φιλτραρισμένο εύρος...
  • Συγχώνευση κελιών / σειρών / στηλών χωρίς απώλεια δεδομένων · Περιεχόμενο διαχωρισμού κελιών Συνδυάστε διπλές σειρές / στήλες... Αποτροπή διπλών κυττάρων; Συγκρίνετε τα εύρη...
  • Επιλέξτε Διπλότυπο ή Μοναδικό Σειρές; Επιλέξτε Κενές σειρές (όλα τα κελιά είναι κενά). Σούπερ εύρεση και ασαφής εύρεση σε πολλά βιβλία εργασίας. Τυχαία επιλογή ...
  • Ακριβές αντίγραφο Πολλαπλά κελιά χωρίς αλλαγή της αναφοράς τύπου. Αυτόματη δημιουργία αναφορών σε πολλαπλά φύλλα? Εισαγωγή κουκκίδων, Πλαίσια ελέγχου και άλλα ...
  • Εξαγωγή κειμένου, Προσθήκη κειμένου, Κατάργηση κατά θέση, Αφαιρέστε το διάστημα; Δημιουργία και εκτύπωση υποσύνολων σελιδοποίησης. Μετατροπή περιεχομένου και σχολίων μεταξύ κελιών...
  • Σούπερ φίλτρο (αποθηκεύστε και εφαρμόστε σχήματα φίλτρων σε άλλα φύλλα). Προηγμένη ταξινόμηση ανά μήνα / εβδομάδα / ημέρα, συχνότητα και άλλα. Ειδικό φίλτρο με έντονη, πλάγια ...
  • Συνδυάστε βιβλία εργασίας και φύλλα εργασίας; Συγχώνευση πινάκων βάσει βασικών στηλών. Διαχωρίστε τα δεδομένα σε πολλά φύλλα; Μαζική μετατροπή xls, xlsx και PDF...
  • Περισσότερα από 300 ισχυρά χαρακτηριστικά. Υποστηρίζει Office / Excel 2007-2021 και 365. Υποστηρίζει όλες τις γλώσσες. Εύκολη ανάπτυξη στην επιχείρηση ή τον οργανισμό σας. Πλήρεις δυνατότητες δωρεάν δοκιμής 30 ημερών. Εγγύηση επιστροφής χρημάτων 60 ημερών.
kte καρτέλα 201905

Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
κάτω μέρος γραφείου
Σχόλια (36)
Δεν υπάρχουν ακόμη βαθμολογίες. Γίνε ο πρώτος που θα αξιολογήσετε!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
πώς να το κάνουμε σε mul;tiple πεδίο αφού στον κώδικα υπάρχει μόνο ένας στόχος
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Frank
Η Σόρυ δεν μπορεί να σε βοηθήσει με αυτό.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Τι γίνεται αν το κελί που είναι συνδεδεμένο με τον Συγκεντρωτικό Πίνακα, σε αυτήν την περίπτωση το H6, βρίσκεται σε άλλο φύλλο εργασίας; Πώς αλλάζει τον κωδικό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
τι γίνεται αν έχω περισσότερους από 1 συγκεντρωτικούς πίνακες και να συνδέσω σε 1 κελί. Πώς να τροποποιήσω τον κωδικό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Jeri,
Συγγνώμη δεν μπορώ να σε βοηθήσω με αυτό. Καλώς ήρθατε να δημοσιεύσετε οποιαδήποτε ερώτηση στο φόρουμ μας: https://www.extendoffice.com/forum.html για να λάβετε περισσότερη υποστήριξη Excel από επαγγελματίες του Excel ή άλλους οπαδούς του Excel.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
βρείτε αυτά και αλλάξτε τα στο Array(),Intersect(), Worksheets(), PivotFields()

Συγκεντρωτικός πίνακας1
Συγκεντρωτικός πίνακας2
Συγκεντρωτικός πίνακας3
Συγκεντρωτικός πίνακας4
H1
Όνομα φύλλου
Ονομα πεδίου




Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180702
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xPTabled As PivotTable
    Dim xPFiled As PivotField
    Dim xStr As String
    On Error Resume Next
    '리스트 만들기
    Dim listArray() As Variant
    listArray = Array("PivotTable1", "PivotTable2", "PivotTable3", "PivotTable4")
    If Intersect(Target, Range("H1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For i = 0 To UBound(listArray)
        Set xPTable = Worksheets("SheetName").PivotTables(listArray(i))
        Set xPFile = xPTable.PivotFields("FieldName")
        'MsgBox (listArray(i))
        xStr = Target.Text
        xPFile.ClearAllFilters
        xPFile.CurrentPage = xStr
    Next
        Application.ScreenUpdating = True
End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Boa tarde...! Ótima publicação, como faço para utilizar o filtro em duas ou mais tabelas dinâmicas...? Agradeço desde já.

Καλό απόγευμα...! Εξαιρετική δημοσίευση, πώς μπορώ να χρησιμοποιήσω το φίλτρο σε δύο ή περισσότερους Συγκεντρωτικούς Πίνακες ...; Ευχαριστώ εκ των προτέρων.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Gilmar Alves,
Συγγνώμη δεν μπορώ να σε βοηθήσω με αυτό. Καλώς ήρθατε να δημοσιεύσετε οποιαδήποτε ερώτηση στο φόρουμ μας: https://www.extendoffice.com/forum.html για να λάβετε περισσότερη υποστήριξη Excel από επαγγελματίες του Excel ή άλλους οπαδούς του Excel.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Έχει καταλάβει κανείς την ερώτηση σύνδεσης πολλαπλών συγκεντρωτικών πινάκων;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αλλαγή τιμών σε Array(), Worksheets() και Intersect()



**Βρείτε αυτά και αλλάξτε τα**
Όνομα φύλλου
E1
Συγκεντρωτικός πίνακας1
Συγκεντρωτικός πίνακας2
Συγκεντρωτικός πίνακας3




Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
«Ενημέρωση από Extendoffice 20180702
Dim xPTable ως Συγκεντρωτικός Πίνακας
Dim xPFile ως PivotField

Dim xPTabled As PivotTable
Dim xPFiled As PivotField

Dim xStr ως συμβολοσειρά



On Error Συνέχιση Επόμενη

'리스트 만들기
Dim listArray() Ως παραλλαγή
listArray = Πίνακας ("Συγκεντρωτικός Πίνακας1", "Συγκεντρωτικός Πίνακας2", "Συγκεντρωτικός Πίνακας3")



Εάν το Intersect(Target, Range("E1")) δεν είναι τίποτα, τότε βγείτε από το Sub
Application.ScreenUpdating = False

Για i = 0 To UBound(listArray)

Ορισμός xPTable = Φύλλα εργασίας ("Όνομα φύλλου"). Συγκεντρωτικοί Πίνακες(listArray(i))
Ορισμός xPFile = xPTable.PivotFields("Company_ID")

xStr = Στόχος.Κείμενο
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr



Επόμενο

Application.ScreenUpdating = True



Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ciao, sto provando a fare lo stesso esempio per far in modo che il filtro della pivot si setti sul valore della cella,
non riesco a farla funzionare.

Ποιο passaggio manca nella descrizione sopra;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,
Λάβατε κάποιο μήνυμα σφάλματος; Πρέπει να μάθω πιο συγκεκριμένα για το πρόβλημά σας, όπως την έκδοση του Excel. Και αν δεν σας πειράζει, δοκιμάστε να δημιουργήσετε τα δεδομένα σας σε ένα νέο βιβλίο εργασίας και δοκιμάστε ξανά ή τραβήξτε ένα στιγμιότυπο οθόνης των δεδομένων σας και ανεβάστε τα εδώ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,

Προσπάθησα να το πετύχω για το φίλτρο στήλης αλλά δεν φαίνεται να λειτουργεί. Χρειάζομαι άλλο κωδικό για αυτό;

Ευχαριστώ
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Justin,
Λάβατε κάποιο μήνυμα σφάλματος; Πρέπει να μάθω πιο συγκεκριμένα για το πρόβλημά σας.
Πριν εφαρμόσετε τον κωδικό, μην ξεχάσετε να τροποποιήσετε το "όνομα του φύλλου""όνομα του συγκεντρωτικού πίνακα""όνομα του φίλτρου του συγκεντρωτικού πίνακα" και το κύτταρο θέλετε να φιλτράρετε τον συγκεντρωτικό πίνακα με βάση (δείτε στιγμιότυπο).
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/4.png
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Crystal,

Ευχαριστώ για τη βοήθειά σου. Το θέμα είναι ότι η συνάρτηση δεν κάνει τίποτα για κάποιο λόγο. Κάποια διευκρίνηση:

Όνομα άξονα: Order_Comp_B2C
Όνομα Φύλλου: Φύλλο Υπολογισμού
Όνομα φίλτρου: Αριθμός εβδομάδας (Άλλαξα αυτό το όνομα από αυτό που ήταν "Αριθμός Εβδομάδας αποστολής" στο αρχείο δεδομένων)
Κελλί προς αλλαγή: O26 και O27 (αυτό θα πρέπει να είναι εντός εύρους)

Σε αυτό το pivot, προσπαθώ να αλλάξω το φίλτρο για τις στήλες, δεν έχω τίποτα στην περιοχή φίλτρου στο μενού Πεδία Συγκεντρωτικού Πίνακα.

ο κωδικός μου είναι:

Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
«Ενημέρωση από Extendoffice 20180702
Dim xPTable ως Συγκεντρωτικός Πίνακας
Dim xPFile ως PivotField
Dim xStr ως συμβολοσειρά
On Error Συνέχιση Επόμενη
Εάν το Intersect(Target, Range("O26")) δεν είναι τίποτα, τότε βγείτε από το Sub
Application.ScreenUpdating = False
Ορισμός xPTable = Φύλλα εργασίας ("Φύλλο Υπολογισμού"). Συγκεντρωτικοί Πίνακες ("Order_Comp_B2C")
Ορισμός xPFile = xPTable.PivotFields("Αριθμός εβδομάδας")
xStr = Στόχος.Κείμενο
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True
Sub End

Ευχαριστώ,

Justin
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Justin Teeuw,
έχω αλλάξει το Όνομα άξονα, όνομα φύλλου, όνομα φίλτρου και κελί για αλλαγή σύμφωνα με τις συνθήκες που αναφέρατε παραπάνω και δοκιμάσατε τον κωδικό VBA που παρείχατε, λειτουργεί καλά στην περίπτωσή μου. Δείτε το παρακάτω GIF ή το συνημμένο βιβλίο εργασίας.
Σας πειράζει να δημιουργήσετε ένα νέο βιβλίο εργασίας και να δοκιμάσετε ξανά τον κώδικα;
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/6.gif
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Crystal,

Επισυνάπτεται ένα στιγμιότυπο οθόνης του άξονα, το κόκκινο πλαίσιο είναι το φίλτρο που θα ήθελα να αλλάξω με βάση την τιμή του κελιού.

Κατά προτίμηση, θα ήθελα να χρησιμοποιήσω μια σειρά κελιών που υποδεικνύουν αριθμούς πολλών εβδομάδων.

Ευχαριστώ,

Justin
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Justin,
Συγγνώμη που δεν είδα το στιγμιότυπο οθόνης που επισυνάψατε στη σελίδα. Ίσως υπάρχει κάποιο σφάλμα στη σελίδα.
Εάν εξακολουθείτε να χρειάζεται να λύσετε το πρόβλημα, στείλτε μου email μέσω zxm@addin99.com. Συγγνώμη για την ταλαιπωρία.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Justin Teeuw,
Δοκιμάστε τον παρακάτω κώδικα VBA. Ελπίζω να μπορώ να βοηθήσω.

Private Sub Worksheet_Change(ByVal Target As Range)
    'Update by Extendoffice 20220706
    Dim I As Integer
    Dim xFilterStr1, xFilterStr2 As String
    On Error Resume Next
    If Intersect(Target, Range("O26:O27")) Is Nothing Then Exit Sub
    'Application.ScreenUpdating = False
    
    xFilterStr1 = Range("O26").Value
    xFilterStr2 = Range("O27").Value
    ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number"). _
        ClearAllFilters
    If xFilterStr1 = "" And xFilterStr2 = "" Then Exit Sub
    ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number"). _
        EnableMultiplePageItems = True
    xCount = ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems.Count

    For I = 1 To xCount
        If I <> xFilterStr1 And I <> xFilterStr2 Then
            ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems(I).Visible = False
        Else
            ActiveSheet.PivotTables("Order_Comp_B2C").PivotFields("Week Number").PivotItems(I).Visible = True
        End If
    Next

    'Application.ScreenUpdating = True
End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Το χρησιμοποίησα για ένα κανονικό excell και λειτούργησε. Αλλά δεν μπορούσα να το χρησιμοποιήσω για φύλλα εργασίας olap. μήπως πρέπει να το αλλάξω λίγο;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου maziaritib4 TIB,
Η μέθοδος είναι διαθέσιμη μόνο για το Microsoft Excel. Συγγνώμη για την ταλαιπωρία.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Justin,

Αυτό λειτούργησε τέλεια, ωστόσο, αναρωτιέμαι αν αυτός ο κανόνας μπορεί να εφαρμοστεί σε πολλούς Συγκεντρωτικούς Πίνακες στο ίδιο φύλλο;

Ευχαριστώ,
James
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Hi James,

Ναι, αυτό είναι δυνατό, ο κώδικας που χρησιμοποίησα για αυτό είναι (4 pivots και 2 αναφορές κελιών):

Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
Dim I ως ακέραιος αριθμός
Dim xFilterStr1, xFilterStr2, yFilterstr1, yfilterstr2 ως συμβολοσειρά
On Error Συνέχιση Επόμενη
Εάν το Intersect(Target, Range("O26:P27")) δεν είναι τίποτα, τότε βγείτε από το δευτερεύον

xFilterStr1 = Εύρος ("O26").Τιμή
xFilterStr2 = Εύρος ("O27").Τιμή
yFilterstr1 = Εύρος ("p26").Τιμή
yfilterstr2 = Εύρος ("p27").Τιμή
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Αριθμός εβδομάδας"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Αριθμός εβδομάδας"). _
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Αριθμός εβδομάδας"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Αριθμός εβδομάδας"). _
ClearAllFilters

Αν xFilterStr1 = "" Και xFilterStr2 = "" Και yFilterstr1 = "" Και yfilterstr2 = "" Τότε βγείτε από το Sub
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Αριθμός εβδομάδας"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Αριθμός εβδομάδας"). _
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Αριθμός εβδομάδας"). _
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Αριθμός εβδομάδας"). _
EnableMultiplePageItems = True

xCount = ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Week Number").PivotItems.Count
xCount = ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Week Number").PivotItems.Count
yCount = ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Week Number").PivotItems.Count
yCount = ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Week Number").PivotItems.Count

Για I = 1 To xCount
Αν <> xFilterStr1 Και εγώ <> xFilterStr2 Τότε
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Week Number").PivotItems(I).Visible = False
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Week Number").PivotItems(I).Visible = False
Αλλού
ActiveSheet.PivotTables("Order_Comp_B2C_Crea").PivotFields("Week Number").PivotItems(I).Visible = True
ActiveSheet.PivotTables("Order_Comp_B2B_Crea").PivotFields("Week Number").PivotItems(I).Visible = True
End If
Επόμενο

Για I = 1 To yCount
Αν <> yFilterstr1 Και εγώ <> yfilterstr2 Τότε
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Week Number").PivotItems(I).Visible = False
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Week Number").PivotItems(I).Visible = False
Αλλού
ActiveSheet.PivotTables("Order_Comp_B2C_Disp").PivotFields("Week Number").PivotItems(I).Visible = True
ActiveSheet.PivotTables("Order_Comp_B2B_Disp").PivotFields("Week Number").PivotItems(I).Visible = True
End If
Επόμενο

Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αλλαγή τιμών σε Array(), Worksheets() και Intersect()



**Βρείτε αυτά και αλλάξτε τα**
Όνομα φύλλου
E1
Συγκεντρωτικός πίνακας1
Συγκεντρωτικός πίνακας2
Συγκεντρωτικός πίνακας3




Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
«Ενημέρωση από Extendoffice 20180702
Dim xPTable ως Συγκεντρωτικός Πίνακας
Dim xPFile ως PivotField

Dim xPTabled As PivotTable
Dim xPFiled As PivotField

Dim xStr ως συμβολοσειρά



On Error Συνέχιση Επόμενη

'리스트 만들기
Dim listArray() Ως παραλλαγή
listArray = Πίνακας ("Συγκεντρωτικός Πίνακας1", "Συγκεντρωτικός Πίνακας2", "Συγκεντρωτικός Πίνακας3")



Εάν το Intersect(Target, Range("E1")) δεν είναι τίποτα, τότε βγείτε από το Sub
Application.ScreenUpdating = False

Για i = 0 To UBound(listArray)

Ορισμός xPTable = Φύλλα εργασίας ("Όνομα φύλλου"). Συγκεντρωτικοί Πίνακες(listArray(i))
Ορισμός xPFile = xPTable.PivotFields("Company_ID")

xStr = Στόχος.Κείμενο
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr



Επόμενο

Application.ScreenUpdating = True



Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.

Ο κωδικός λειτουργεί καλά για μένα. Ωστόσο, δεν μπορώ να λάβω τον συγκεντρωτικό πίνακα για αυτόματη ενημέρωση του στόχου φίλτρου. Ο στόχος στην περίπτωσή μου είναι ένας τύπος [DATE(D18,S14,C18)]. Ο κωδικός λειτουργεί μόνο όταν κάνω διπλό κλικ στο κελί προορισμού και πατήσω enter.

Ευχαριστούμε
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.

Αυτός ο κώδικας λειτουργεί τέλεια. Ωστόσο, δεν μπορώ να λάβω τον κωδικό για αυτόματη ενημέρωση του συγκεντρωτικού πίνακα. Η τιμή στόχος για μένα είναι ένας τύπος (=DATE(D18,..,..)) που αλλάζει ανάλογα με το τι έχει επιλεγεί στο D18. Για να ενημερώσει τον συγκεντρωτικό πίνακα πρέπει να κάνω διπλό κλικ στο κελί προορισμού και να πατήσω enter. Υπάρχει τρόπος να το παρακάμψετε;

Ευχαριστούμε
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου ST,
Ας υποθέσουμε ότι η τιμή στόχος είναι στο H6 και αλλάζει ανάλογα με την τιμή στο D18. Για να φιλτράρετε έναν συγκεντρωτικό πίνακα με βάση αυτήν την τιμή στόχο. Ο παρακάτω κώδικας VBA μπορεί να βοηθήσει. Δοκιμάστε το.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/07/22
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xBoolean As Boolean
Dim xItsRG As Range
Dim xDDs As Range
Dim xDs As Range
On Error Resume Next

xBoolean = False
Set xRg = Range("h6")

Set xItsRG = Intersect(Target, xRg)
Set xDDs = Intersect(Target.DirectDependents, xRg)
Set xDs = Intersect(Target.Dependents, xRg)
If Not (xItsRG Is Nothing) Then
    xBoolean = True
ElseIf Not (xDDs Is Nothing) Then
    xBoolean = True
ElseIf Not (xDs Is Nothing) Then
    xBoolean = True
End If


If Not xBoolean Then Exit Sub

Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet1").PivotTables("Pivot Table 1")
Set xPFile = xPTable.PivotFields("Category")
xStr = Target.Text
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True

End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Crysal,

Πρόσθεσα μια γραμμή στον κωδικό: Dim xRg As Range

Ο κωδικός δεν επαναφέρει αυτόματα τις ημερομηνίες κατά την αλλαγή του στόχου. Έχω ένα αρχείο excel που αναπαράγει αυτό που προσπαθώ να κάνω, ωστόσο δεν μπορώ να προσθέσω συνημμένα σε αυτόν τον ιστότοπο. Το D3 (στόχος = DATE(A15,B15,C15)) έχει μια εξίσωση που συνδέεται με τα A15, B15 και C15. Όταν αλλάξει οποιαδήποτε τιμή στα A15, B15 και C15, ο συγκεντρωτικός πίνακας επαναφέρεται σε κανένα φίλτρο. Θα μπορούσατε να με βοηθήσετε σε αυτό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου ST,
Δεν καταλαβαίνω καλά τι εννοείς. Στην περίπτωσή σας, η τιμή του κελιού στόχου D3 χρησιμοποιείται για το φιλτράρισμα του συγκεντρωτικού πίνακα. Ο τύπος στο κελί στόχο D3 αναφέρεται στις τιμές των κελιών A15, B15 και C15, οι οποίες θα αλλάξουν ανάλογα με τις τιμές στα κελιά αναφοράς. Όταν αλλάξει οποιαδήποτε τιμή στα A15, B15 και C15, ο συγκεντρωτικός πίνακας θα φιλτράρεται αυτόματα εάν η τιμή στο κελί προορισμού πληροί τις συνθήκες φίλτρου του συγκεντρωτικού πίνακα. Εάν η τιμή στο κελί προορισμού δεν πληροί τα κριτήρια φιλτραρίσματος του συγκεντρωτικού πίνακα, ο συγκεντρωτικός πίνακας θα επαναφερθεί αυτόματα σε μηδενικό φιλτράρισμα.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Δεν είμαι σίγουρος αν υπάρχει τρόπος να μοιραστώ ένα αρχείο excel μαζί σας. Εάν η τιμή-στόχος μου, που είναι μια ημερομηνία, αλλάζει ανάλογα με τις αλλαγές σε άλλα κελιά. Πρέπει να κάνω διπλό κλικ στο κελί προορισμού και να πατήσω enter (όπως θα κάνατε μετά την εισαγωγή ενός τύπου σε ένα κελί) για να ενημερώσετε τον συγκεντρωτικό πίνακα
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Sagar T,
Ο κωδικός έχει ενημερωθεί. Δοκιμάστε το. Ευχαριστούμε για την ανταπόκριση σας.
Μην ξεχάσετε να αλλάξετε τα ονόματα του φύλλου εργασίας, του συγκεντρωτικού πίνακα και του φίλτρου στον κώδικα. Ή μπορείτε να κατεβάσετε το παρακάτω μεταφορτωμένο βιβλίο εργασίας για δοκιμή.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220805
Dim xPTable As PivotTable
Dim xPFile As PivotField
Dim xStr As String
Dim xBoolean As Boolean
Dim xItsRG As Range
Dim xDDs As Range
Dim xDs As Range
On Error Resume Next

xBoolean = False
Set xRg = Range("D3")

Set xItsRG = Intersect(Target, xRg)
Set xDDs = Intersect(Target.DirectDependents, xRg)
Set xDs = Intersect(Target.Dependents, xRg)
If Not (xItsRG Is Nothing) Then
    xBoolean = True
ElseIf Not (xDDs Is Nothing) Then
    xBoolean = True
ElseIf Not (xDs Is Nothing) Then
    xBoolean = True
End If


If Not xBoolean Then Exit Sub
xStr = Format(xRg.Text, "m/d/yyyy")
Application.ScreenUpdating = False
Set xPTable = Worksheets("Sheet2").PivotTables("PivotTable1")
Set xPFile = xPTable.PivotFields("Date")
xPFile.ClearAllFilters
xPFile.CurrentPage = xStr
Application.ScreenUpdating = True

End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
βρείτε αυτά και αλλάξτε τα στο Array(),Intersect(), Worksheets(), PivotFields()

Συγκεντρωτικός πίνακας1
Συγκεντρωτικός πίνακας2
Συγκεντρωτικός πίνακας3
Συγκεντρωτικός πίνακας4
H1
Όνομα φύλλου
Ονομα πεδίου




Private Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180702
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xPTabled As PivotTable
    Dim xPFiled As PivotField
    Dim xStr As String
    On Error Resume Next
    '리스트 만들기
    Dim listArray() As Variant
    listArray = Array("PivotTable1", "PivotTable2", "PivotTable3", "PivotTable4")
    If Intersect(Target, Range("H1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For i = 0 To UBound(listArray)
        Set xPTable = Worksheets("SheetName").PivotTables(listArray(i))
        Set xPFile = xPTable.PivotFields("FieldName")
        'MsgBox (listArray(i))
        xStr = Target.Text
        xPFile.ClearAllFilters
        xPFile.CurrentPage = xStr
    Next
        Application.ScreenUpdating = True
End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Как сделать чтобы сводная таблица применяла сразу 2 фильтра из 2хразных ячеек? και δεν είναι 1 όπως για παράδειγμα;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου, Алексеј,

Ελέγξτε εάν ο κωδικός VBA σε αυτό το σχόλιο #38754 μπορεί να βοηθήσει.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Можно ли сослаться вместо ячейки H6 на ячейку на другом листе? как это сделать; подскажите пожалуйста.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου, Алексеј,

Δεν χρειάζεται να τροποποιήσετε τον κώδικα, απλώς προσθέστε τον κώδικα VBA στο φύλλο εργασίας του κελιού που θέλετε να αναφέρετε.
Για παράδειγμα, εάν θέλετε να φιλτράρετε έναν συγκεντρωτικό πίνακα με το όνομα "Συγκεντρωτικός πίνακας1«Σε Sheet2 με βάση την τιμή του κελιού H6 in Sheet3, κάντε δεξί κλικ στο Sheet3 καρτέλα φύλλου εργασίας, κάντε κλικ Προβολή κωδικού από το μενού που κάνει δεξί κλικ και, στη συνέχεια, προσθέστε τον κωδικό στο Φύλλο 3 (Κωδικός) παράθυρο.
Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Αφήστε τα σχόλιά σας
Δημοσίευση ως επισκέπτης
×
Αξιολογήστε αυτήν την ανάρτηση:
0   Χαρακτήρες
Προτεινόμενες τοποθεσίες

Ακολουθησε μας

Πνευματικά δικαιώματα © 2009 - www.extendoffice.com. | Ολα τα δικαιώματα διατηρούνται. Τροφοδοτείται από ExtendOffice. | Sitemap
Το Microsoft και το λογότυπο του Office είναι εμπορικά σήματα ή σήματα κατατεθέντα της Microsoft Corporation στις Ηνωμένες Πολιτείες ή / και σε άλλες χώρες.
Προστατεύεται από το Sectigo SSL