Φιλτράρισμα λίστας και δημιουργία φύλλων για όλες τις τιμές πεδίου

Η μακροεντολή, τον κώδικα της οποίας θα βρείτε πιο κάτω, ασχολείται, όπως και η μάκρο του προηγουμένου σημειώματος, με τη γρήγορη εξαγωγή φιλτραρισμένων διαδεδομένων σε νέα φύλλα, αλλά είναι πιο γενική από εκείνη. Διατρέχει ένα πεδίο μιας βάσης, φιλτράρει ως προς κάθε διαφορετική τιμή του πεδίου, και για κάθε φιλτράρισμα προσθέτει ένα φύλλο στο βιβλίο σας.
Στη λίστα (πίνακα, βάση) της εικόνας, με επιλεγμένη την ετικέτα του πεδίου «Από Κατάστημα», η μακροεντολή δημιούργησε για κάθε ένα από τα καταστήματα της στήλης Α, ένα διαφορετικό φύλλο, φιλτράροντας ταυτόχρονα και παρουσιάζοντας σε κάθε φύλλο όλες τις εγγραφές (γραμμές) της βάσης για το κατάστημα αυτό.

SplitFieldOfTableFirst
Στη γραμμή με τις καρτέλες φύλλων θα δείτε μια εικόνα σαν και αυτή:

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

SplitFieldOfTable02
Μπορείτε να τρέξετε τη μάκρο για όποιο πεδίο (στήλη) ανεξάρτητα αν περιέχει κείμενο, αριθμούς, ημερομηνίες, ώρες, λογικές τιμές, συναρτήσεις, σφάλματα. Ειδικά οι συναρτήσεις θα περάσουν στους επί μέρους πίνακες σαν τιμές, αξίες και όχι σαν συναρτήσεις. Αν στη στήλη υπάρχουν κενά κελιά θα πάρετε και ένα ξεχωριστό φύλλο με όνομα «κενό» που θα περιέχει τις εγγραφές αυτές. Αν στα κελιά του πίνακα υπάρχουν χαρακτήρες που δεν επιτρέπεται να χρησιμοποιηθούν στο όνομα ενός φύλλου, δηλαδή ένας από τους χαρακτήρες:

 *  /  :  ?  [   ]  \ 

θα αντικατασταθούν από την κάτω παύλα: _ Παράδειγμα, αν θελήσετε φιλτράρισμα ανά ημερομηνία, τα φύλλα που θα πάρετε θα έχουν ονόματα σαν αυτό: 07_01_14.  Αν ξανατρέξετε την μακροεντολή για το ίδιο πεδίο, χωρίς προηγουμένως να διαγράψετε από το βιβλίο σας τα φύλλα που προστέθηκαν από το ίδιο πεδίο, τα νέα ονόματα των φύλλων θα είναι διαφοροποιημένα με έναν αριθμητικό δείκτη. Για το παράδειγμα των καταστημάτων θα πάρετε φύλλα όπως της εικόνας:

SplitFieldOfTable03
Τρέξτε τη μακροεντολή αφού προηγουμένως έχετε επιλέξει ένα τίτλο (ετικέτα) μιας βάσης της οποίας η δόμηση υπακούει στους απλούς κανόνες που θέτει το excel. Τους κανόνες αυτούς συζητήσαμε στο αμέσως προηγούμενο σημείωμα. Αν πιστεύετε ότι θα σας φανεί χρήσιμη, σαν ρουτίνα γενικής χρήσης, πιο καλά να την γράψετε στο βιβλίο προσωπικών μακροεντολών.
Ανοίξτε το πλαίσιο για να δείτε τον κώδικα:

Sub SplitFieldOfTable()
'Από το Excel Λύσεις

Dim rw As Integer
Dim keli As Range
Dim myBase As Range
Dim pedio As String
Dim myPivotSheet As String
Dim msg As String
Dim newName As String
Dim myActSh As String

myActSh = ActiveSheet.Name
msg = "Δεν επιλέξατε ετικέτα πεδίου (στήλης) μιάς βάσης"

    If Not TypeName(Selection) = "Range" Then MsgBox msg: GoTo telos
Set keli = Selection
    If keli.Count > 1 Then MsgBox msg: GoTo telos
Set myBase = keli.CurrentRegion
    If myBase.Rows.Count = 1 Then MsgBox msg: GoTo telos
    If Not keli.Row = myBase.Row Then MsgBox msg: GoTo telos
pedio = keli.Value

On Error GoTo telos
Application.ScreenUpdating = False

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
    myBase.Address).CreatePivotTable TableDestination:="", TableName:="ooHelpPivot"

With ActiveSheet.PivotTables("ooHelpPivot")
    .PivotFields(pedio).Orientation = xlRowField
    .PivotFields(pedio).Orientation = xlDataField
    .ColumnGrand = False
    .RowGrand = False
End With

myPivotSheet = ActiveSheet.Name

For rw = 3 To Application.CountA(Range("A:A"))
newName = Sheets(myPivotSheet).Cells(rw, "A").text
newName = ClearIllegalCharacters(newName)
Sheets(myPivotSheet).Cells(rw, "B").ShowDetail = True
If CheckSheetExist(newName) = False Then
    ActiveSheet.Name = newName

'Αν υπάρχει ήδη στο βιβλίο φύλλο με το ίδιο όνομα
'καλείται η συνάρτηση CounterSheets
Else: ActiveSheet.Name = newName & "(" & 1 + CounterSheets(newName) & ")"

'Εναλλακτικά στη θέση της προηγούμενης εντολής,ενεργοποιήστε την επόμενη
'γραμμή του κώδικα η οποία διαφοροποιεί το όνομα του φύλλου, προσθέτοντας
'στο όνομά του την πλήρη ημερομηνία & ώρα στη μορφή _εεμμηη_ωωλλδδ
'Else: ActiveSheet.Name = newName & Format(Date, "_yymmdd_") & Format(Time, "hhmmss")

End If
ActiveSheet.Cells(1, 1).Select
Next

Application.DisplayAlerts = False
Sheets(myPivotSheet).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
telos:
Sheets(myActSh).Select
End Sub

Private Function CheckSheetExist(ByVal SheetName As String) As Boolean
'Η συνάρτηση ελέγχει αν υπάρχει ήδη στο βιβλίο φύλλο με ίδιο όνομα
'με αυτό που προσπαθεί να εισάγει η μακροεντολή.
On Error Resume Next
CheckSheetExist = (Sheets(SheetName).Name <> "")
On Error GoTo 0
End Function

Private Function CounterSheets(ByVal SheetName As String) As Integer
'Αν η προηγούμενη συνάρτηση διαπιστώσει ότι υπάρχουν φύλλα
'με το ίδιο όνομα,τότε αυτή η συνάρτηση μετρά το πλήθος τους
'ώστε το επόμενο να εισαχθεί με το σωστό όνομα ακολουθούμενο
'από έναν αριθμητικό δείκτη, κατά 1 μεγαλύτερο από το πλήθος.
Dim Sh As Worksheet
Dim k As Integer
CounterSheets = 0
For Each Sh In Worksheets
If Sh.Name Like SheetName & "*" Then CounterSheets = CounterSheets + 1
Next
End Function

Private Function ClearIllegalCharacters(ByVal SheetName As String) As String
'Αντικαθιστά με την κάτω παύλα (_) τους χαρακτήρες που δεν επιτρέπονται
'να υπάρχουν στο όνομα ενός φύλλου, δηλαδή τους  * / : ? [  ] \
Dim i As Integer
Dim IllChar As Variant
IllChar = Array(42, 47, 58, 63, 91, 92, 93)
SheetName = Application.Trim(SheetName)
For i = LBound(IllChar) To UBound(IllChar)
SheetName = Replace(SheetName, ChrW(IllChar(i)), "_")
Next i
SheetName = Left(SheetName, 25)
ClearIllegalCharacters = SheetName
End Function

Ο κώδικας δουλεύει ως εξής: Αφού ελέγξει αν ο χρήστης έχει επιλέξει τον τίτλο (ετικέτα) ενός πεδίου βάσης, και εκτιμήσει το εύρος της βάσης, δημιουργεί στο παρασκήνιο έναν συγκεντρωτικό πίνακα (pivot) με πεδίο γραμμών (xlRowField) το επιλεγμένο πεδίο, και στοιχεία δεδομένων (xlDataField) το ίδιο πεδίο.
Κατόπιν ένας βρόχος for…next διατρέχει ένα-ένα τα κελιά με τα δεδομένα του pivot και για κάθε ένα καλεί την ιδιότητα ShowDetail που είναι το vba ισοδύναμο του χειριστικού διπλοπατήματος με το ποντίκι σε στοιχείο ενός pivot. Θυμίζω ότι το διπλοπάτημα, δημιουργεί ένα νέο φύλλο όπου είναι συγκεντρωμένες όλες οι εγγραφές της αρχικής βάσης που συνέβαλαν για την τιμή αυτή. Αυτό εκμεταλλεύεται ο κώδικας και τα φύλλα δημιουργούνται γρήγορα και με σιγουριά. Στην πράξη, πουθενά ο κώδικας δεν κάνει πραγματικό φιλτράρισμα. Τρεις vba συναρτήσεις που συνοδεύουν τη μακροεντολή, την βοηθούν να εισάγει τα φύλλα με σωστά ονόματα στο βιβλίο. Περιγραφή για αυτές θα βρείτε στον κώδικα.
Στο excel βιβλίο SplitField.xls θα βρείτε μια πιο φιλόδοξη εκδοχή της ίδιας μακροεντολής. Ο χρήστης επιλέγει την ετικέτα του πεδίου και η μάκρο εμφανίζει ένα listbox με όλες τις μοναδικές τιμές του πεδίου, αλφαβητικά ταξινομημένες, απ’ όπου μπορεί να επιλέξει για ποιες από αυτές θέλει να δημιουργήσει χωριστή σελίδα. Κατεβάστε το βιβλίο SplitField.xls από εδώ ή από εδώ, για να δείτε τον κώδικα και πως δουλεύει.

SplitFieldOfTable04

This entry was posted in excel, Μακροεντολές, Συναρτήσεις Χρήστη, Φίλτρα, Pivot, VBA and tagged , , , , , . Bookmark the permalink.

7 Responses to Φιλτράρισμα λίστας και δημιουργία φύλλων για όλες τις τιμές πεδίου

  1. Ο/Η Nikos Gkikas λέει:

    Αγαπητε Γιαννη ερχομαι παλι σε επικοινωνια γιατι χρειαζομαι τα φωτα σου !!! παλι .
    Προσπαθω να τρεξω την μακροεντολη σε ecxel 2010 αλλα δεν ….. !
    Εχω ενα φυλλο με 100000 εγγραφες (σειρες) και αντιστοιχα γυρω στις 30 στηλες και κατι δεν παει καλα .

    Θα μπορουσες να με διαφωτισεις και παλι ?!
    Ευχαριστω εκ των προτερων
    Νικος

  2. Ο/Η vioannis λέει:

    Νίκο, τροποποίησε την 28η σειρά του κώδικα από

    myBase).CreatePivotTable TableDestination:="", TableName:="ooHelpPivot"
    

    σε

    myBase.Address).CreatePivotTable TableDestination:="", TableName:="ooHelpPivot"
    

    (δηλαδή το myBase) γίνεται myBase.Address)
    Και πες μου αν λύθηκε το πρόβλημα.

  3. Ο/Η Nikos Gkikas λέει:

    Ok δουλευει , με μια διαφορα δεν βγαζει το πινακακι για να κανω εγω τις επιλογες ποιες τιμες θελω να μου δημιουργεσει να νεα φυλλα … με αποτελεσμα να μου τα βγαζει ολα !

  4. Ο/Η vioannis λέει:

    Ο κώδικας που υπάρχει στο άρθρο, δεν βγάζει listbox, έτσι δουλεύει. Ο κώδικας με το listbox είναι διαφορετικός και θα τον βρεις στο βιβλίο SplitField.xls. Τέλος πάντων, αφού εντοπίστηκε το πρόβλημα, θα πούμε λεπτομέρειες και πως θα μεταφέρεις τον κώδικα του SplitField.xls στο βιβλίο σου, αύριο ή μεθαύριο.

  5. Ο/Η Nikos Gkikas λέει:

    Οκ ευχαριστω για τον χρονο σου

  6. Ο/Η Nikos Gkikas λέει:

    Γιαννη καλημερα , τελικα δουλεψε και το list box με την αντιστοιχη αλλαγη με το myBase.Address.
    Ευχαριστω και παλι !!!

  7. Ο/Η vioannis λέει:

    Ο κώδικας SplitFieldOfTable όπως και το βιβλίο SplitField.xls, έχουν διορθωθεί και δεν παρουσιάζουν πρόβλημα με βάσεις με πολλές χιλιάδες εγγραφές.
    Να σημειώσω για όσους φίλους που ασχολούνται με την vba και ίσως αντιμετωπίσουν το ίδιο πρόβλημα: Όπως περιγράφω στο σημείωμα, της δημιουργίας των φύλλων προηγείται η δημιουργία ενός pivot με τη μέθοδο PivotCaches.Add (γραμμές 27-28 του κώδικα).Μια παράμετρος της μεθόδου είναι η Variant SourceData (δηλαδή το σύνολο της βάσης, η οποία έχει δηλωθεί στον κώδικα σαν myBase). Η παράμετρος SourceData μπορεί να εισαχθεί σαν αντικείμενο range ή σαν αναφορά διεύθυνσης (string ). Αν όμως εισαχθεί σαν range τότε, ακόμα και αν ο κώδικας τρέχει σε σε excel 2007 και νεώτερο, θεωρεί ότι η μέγιστη τιμή για το πλήθος των γραμμών του φύλλου είναι 65536. Αν λοιπόν η βάση επεκτείνεται σε περισσότερες γραμμές, ο κώδικας παράγει ένα λάθος και τερματίζει.
    Πιθανά είναι και αυτό ένα ξεχασμένο όριο από τα παλιότερα excel. Το πρόβλημα διορθώνεται αν η SourceData εισαχθεί σαν αναφορά διεύθυνσης (SourceData:= myBase.Address αντί για SourceData:= myBase) και έτσι ο κώδικας μπορεί να τρέξει σε όλες τις εκδόσεις excel χωρίς πρόβλημα.
    Οι συχνοί επισκέπτες του κοστολογίου, θα έχετε παρατηρήσει ότι επιμένω, τα θέματα που ανεβάζω, να είναι συμβατά με όλες τις εκδόσεις του excel, τουλάχιστον έως και την έκδοση 2000. Η προσωπική μου εκτίμηση είναι ότι εκδόσεις 2000,2002 και 2003 σε οικιακή χρήση ίσως να λιγοστευτούν, αλλά υπάρχουν ακόμα σε λειτουργία σε πολλές επιχειρήσεις και χώρους δουλειάς. Εκτός από λίγες περιπτώσεις, δεν είναι δύσκολο να εξασφαλίζεται αυτή η συμβατότητα, άλλωστε και η ίδια η Microsoft φροντίζει για αυτό, αν και υπάρχουν περιπτώσεις, όπως εδώ, που μας επιφυλάσσει εκπλήξεις.

Τα σχόλια είναι απενεργοποιημένα.