Μοναδικές Τιμές. Μακροεντολή και Συνάρτηση

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

Στο παράδειγμα της 1η εικόνας: Επιλέξαμε τις στήλες A και C, τρέξαμε την ρουτίνα και δείξαμε το κελί Ε12 σαν πρώτο κελί εξόδου.
Στη 2η εικόνα: Η μάκρο επέστρεψε στην περιοχή Ε12:Ε35 ταξινομημένες όλες τις μοναδικές τιμές.
ο κώδικας:

 


Sub MonadikesTimes()
'Excel-Λύσεις
Dim j As Long
Dim perioxi As Range
Dim keli As Range
Dim exitkeli As Range

Dim Syllogi As New Collection
Dim item As Variant

Dim Prompt As String: Prompt = "Γράψτε ή δείξτε το πρώτο κελί της στήλης," _
+ vbLf + "όπου θα εξαχθούν ταξινομημένες" _
+ vbLf + "οι μοναδικές τιμές της περιοχής που επιλέξατε"
Dim Title As String: Title = "ΜΟΝΑΔΙΚΕΣ ΤΙΜΕΣ - Excel Λύσεις"

Set perioxi = Intersect(Selection, ActiveSheet.UsedRange)

On Error Resume Next
For Each keli In perioxi
 If keli <> "" Then
 Syllogi.Add keli.Value, CStr(keli.Value)
 End If
Next keli
On Error GoTo 0

If Syllogi.Count = 0 Then GoTo telos
On Error GoTo telos
Set exitkeli = Application.InputBox(Prompt, Title, , , , , , 8)

For Each item In Syllogi
 exitkeli.Offset(j, 0) = item
 j = j + 1
Next

exitkeli.Resize(j, 1).Sort Key1:=exitkeli

telos:
End Sub


 

Στη γραμμή 8 του κώδικα ορίσαμε μία συλλογή και στις γραμμές 18 έως 24 η ρουτίνα διατρέχει όλα τα κελιά της επιλεγμένης περιοχής. Η τιμή κάθε κελιού (που δεν είναι κενό) εισάγεται στη συλλογή με συνοδευτικό κλειδί την ίδια την τιμή του.
Η συλλογές επιτρέπουν την είσοδο διπλοτύπων αλλά δεν επιτρέπουν διπλότυπα κλειδιά. Έτσι την πρώτη φορά που θα συναντήσει μία τιμή θα επιτρέψει την είσοδό της στη συλλογή, αλλά την δεύτερη φορά, επειδή η τιμή θα έχει το ίδιο κλειδί, θα την απορρίψει και θα παραχθεί ένα λάθος. Η VBA θα αγνοήσει το λάθος λόγω της γραμμής 18. Με αυτό τον τρόπο οι τιμές φιλτράρονται και στη συλλογή τελικά εισέρχονται μόνο μοναδικές τιμές. Η τεχνική αυτή (όπως μαρτυρά ο John Walkenbach) πρωτοπαρουσιάστηκε από τον J.G. Hussey στην «Visual Basic Programmer’s Journal».
Με ίδια λογική είναι γραμμένη και η παρακάτω vba συνάρτηση. Δέχεται σαν όρισμα μία ή περισσότερες περιοχές κελιών και επιστρέφει ένα πίνακα – στήλη με όλες τις μοναδικές τιμές που θα βρει εκεί. Επειδή επιστρέφει πολλές τιμές πρέπει να εισαχθεί σαν συνάρτηση – πίνακας πολλών κελιών. (Για τις συναρτήσεις – πίνακες και πως εισάγονται, δες εδώ)
Η VBA συνάρτηση UniqueValue:

 


Function UniqueValue(perioxi As Range) As Variant
'Excel-Λύσεις
Dim keli As Range
Dim Syllogi As New Collection
Dim i As Long
Dim Varray() As Variant
Set perioxi = Intersect(perioxi, ActiveSheet.UsedRange)

On Error Resume Next
For Each keli In perioxi
If keli.Value <> "" Then
Syllogi.Add keli.Value, CStr(keli.Value)
End If
Next keli
On Error GoTo 0

If Syllogi.Count = 0 Then UniqueValue = "": GoTo telos

ReDim Varray(1 To Syllogi.Count)
For i = 1 To Syllogi.Count
Varray(i) = Syllogi(i)
Next i
UniqueValue = Application.Transpose(Varray)
telos:
End Function


Κατεβάστε, αν θέλετε, το excel βιβλίο UniqueValueExample.xls με τον παραπάνω κώδικα.

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

12 Responses to Μοναδικές Τιμές. Μακροεντολή και Συνάρτηση

  1. Ο/Η Γιώργος λέει:

    Γιατί η συνάρτηση μου βγάζει μήνυμα λάθους σύνταξης; Συγκεκριμένα στη γραμμή 9. Μήπως έχεις κάνει κάποια διόρθωση ;

  2. Ο/Η vioannis λέει:

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

     Syllogi.Add keli.Value, CStr(keli.Value) 

    τότε κάλεσε την συνάρτηση CStr κατευθείαν από την βιβλιοθήκη της vba, έτσι:

     Syllogi.Add keli.Value, vba.CStr(keli.Value) 

    Από την άλλη, η συνάρτηση δεν μπορεί να επιστρέψει περισσότερες από 65536 μοναδικές τιμές. Η συνάρτηση με τις μοναδικές τιμές σχηματίζει έναν πίνακα (Varray) και τον επιστρέφει κάθετα σε στήλη με την βοήθεια της Application.Transpose. Αλλά η Transpose ακόμα και στις νεώτερες εκδόσεις του excel εξακολουθεί, στο περιβάλλον της vba, να κουβαλά τοn ίδιο παλιό περιορισμό των 65536 στοιχείων (δηλαδή το πλήθος γραμμών του παλιού φύλλου). Γιατί; Δεν γνωρίζω. Είναι ένα θέμα που έχω σημειώσει να το συζητήσουμε στο μέλλον. Να διευκρινίσω ότι ο περιορισμός αφορά πλήθος επιστρεφόμενων μοναδικών τιμών και όχι πλήθος τιμών που εισάγονται για επεξεργασία στην συνάρτηση, στις τιμές αυτές δεν υπάρχει περιορισμός, πέρα από τα όρια που βάζουν οι πόροι του κάθε συστήματος. Ενημέρωσέ με αν και πως ξεπέρασες το πρόβλημα.

  3. Ο/Η Γιώργος λέει:

    Γιάννη γεια σου. Να με συγχωρήσεις που άργησα στην απάντησή σου. Εννοώ λάθος στη συνάρτηση. Όταν βάζω την συνάρτηση σε ένα κελί μου ανοίγει το παράθυρο της VB (compile error: Syntax error) στην γραμμή “On Error Resume Next”. Πιθανόν να κάνω κάποιο λάθος, αλλά δεν μου δουλεύει (#ΤΙΜΗ).
    Καθώς έγραφα τα προηγούμενα και συνεχίζοντας το ψάξιμο, διαπίστωσα ότι για κάποιο λόγο μου έκανε λάθος αντιγραφή του κώδικα (μάλλον σκουπιδάκια του δικτύου). Διόρθωσα με το “χέρι” την γραμμή και ΟΚ. Πάντως είναι πιο βολική η μακροεντολή γιατί δεν χρειάζεται να επιλέγεις περιοχή για εισαγωγή της συνάρτησης-πίνακα. Κάνω λάθος;

  4. Ο/Η vioannis λέει:

    Είναι θέμα χρήσης. Οι συναρτήσεις είναι πιο δυναμικές και παραμένουν σε «επιφυλακή» να παρακολουθούν τις αλλαγές στις τιμές των ορισμάτων. Την μάκρο πρέπει να τη ξανατρέξεις. Από την άλλη οι μάκρο είναι πιο φιλικές στο χρήστη και δεν βαραίνουν το φύλλο όπως οι συναρτήσεις

  5. Ο/Η Leyteris λέει:

    Καλησπέρα σας. Το έργο σας είναι πολύ χρήσιμο και σας ευχαριστούμε γι΄αυτό. Δεν γνωρίζω πολλά από excel ,έχω το 2010.Προσπαθώ να πάρω μοναδικές τιμές από ένα φύλλο εργασίας σε ένα άλλο για να κάνω διάφορους υπολογισμούς.Για να γίνω πιο συγκεκριμένος έχω δημιουργήσει μια macro η οποία κάνει αρίθμηση και μορφοποίηση ανάλογα με το μήκος και το πλάτος που δίνω σε inputbox στο φύλλο1.Έπειτα γίνεται καταχώρηση στα μορφοποιημένα κελιά.Στο φύλλο2 θέλω να πάρω τις μοναδικές τιμές της περιοχής που καθορίζεται κάθε φορά στο φύλλο1.

    ευχαριστώ πολύ ΧΡΙΣΤΟΣ ΑΝΕΣΤΗ!!

  6. Ο/Η vioannis λέει:

    Χριστός Ανέστη, Χρόνια πολλά!
    Η παραπάνω μάκρο δεν σας καλύπτει;. Όταν εμφανιστεί το InputBox μπορείτε να ορίζεται ένα διαφορετικό φύλλο. Αν η περιοχή στο φύλλο1 με τα διπλότυπα, και στο φύλλο2 εξόδου η περιοχή με τις μοναδικές τιμές, είναι συγκεκριμένες διευθύνεις κελιών, και θέλετε η μεταφορά να μην γίνεται χειριστικά μέσω InputBox, αλλά αυτόματα, ο παραπάνω κώδικας μπορεί εύκολα να τροποποιηθεί. Μην διστάσετε να επανέλθετε και να περιγράφεται με λεπτομέρεια τα βήματα που θέλετε να υλοποιούνται και τις περιοχές

  7. Ο/Η Leyteris λέει:

    Καλημέρα. Ο κώδικας όπως είναι παραπάνω δεν λειτουργεί (δεν γνωρίζω γιατί ).Τα κελιά με τα διπλότυπα καθορίζονται από το inputbox και είναι από το B3 μέχρι το Q200, στο φύλλο2 θέλω να κάνω μια λίστα που να ξεκινάει από το Β3 με τις μοναδικές τιμές, στην διπλανή στήλη να μετράω τα διπλότυπα των τιμών. πχ. στο φύλλο1 έχουμε διάσπαρτα το όνομα ΛΕΥΤΕΡΗΣ 5 φορές, στο φύλλο2 να εμφανίζει στο Β3 το ΛΕΥΤΕΡΗΣ και στο C3 τις φορές που εμφανίζεται δηλ.5 κοκ.Για να σας δώσω μια πιο γενική εικόνα το φύλλο1 είναι σχέδιο εμπορικής έκθεσης που σε κάθε κελί τοποθετώ το όνομα του εκθέτη ,στο φύλλο2 θέλω να κάνω τους υπολογισμούς για τον κάθε εκθέτη.

    Ευχαριστώ για το χρόνο σας!

  8. Ο/Η vioannis λέει:

    Ο κώδικας είναι πολυδοκιμασμένος σε διάφορες εκδόσεις του excel και σίγουρα λειτουργεί. Δεν σε αδικώ όμως. Την τελευταία εβδομάδα η wordpress που φιλοξενεί το ιστολόγιο, έχει πολλά προβλήματα λειτουργίας. Δεν αποκλείεται κατά την αντιγραφή του κώδικα να παρεισέφρησε άσχετο κείμενο. Αν θέλεις επανάλαβε την εργασία. Εγώ με την σειρά μου ανανέωσα και φρεσκάρισα το κείμενο του κώδικα και στο τέλος της ανάρτησης πρόσθεσα ένα excel βιβλίο με ένα παράδειγμα και με τον κώδικα. Κατέβασέ το αν θες.
    Στο δικό σου πρόβλημα τώρα. Έκανα λίγες τροποποιήσεις στην παραπάνω Sub MonadikesTimes, βάση την περιγραφή σου, και προέκυψε ο παρακάτω κώδικας :

    Sub MonadikesTimesTest()
    
    Dim j As Long
    Dim perioxi As Range
    Dim keli As Range
    Dim exitkeli As Range
    Dim Syllogi As New Collection
    Dim item As Variant
    Dim meter As Integer
    
    Set perioxi = Range("Φύλλο1!b3:q200")
    On Error Resume Next
    For Each keli In perioxi
     If Not VBA.IsEmpty(keli) Then
     Syllogi.Add keli.Value, CStr(keli.Value)
     End If
    Next keli
    On Error GoTo 0
     
    If Syllogi.count = 0 Then GoTo telos
    On Error GoTo telos
    
    Set exitkeli = Range("Φύλλο2!b3")
     
    For Each item In Syllogi
        meter = Application.WorksheetFunction.CountIf(perioxi, item)
        exitkeli.Offset(j, 0) = item
        exitkeli.Offset(j, 1) = meter
        j = j + 1
    Next
     
    exitkeli.Resize(j, 2).Sort Key1:=exitkeli
     
    telos:
    End Sub
    

    Μπορείς να τον δεις σε λειτουργία στο βιβλίο: UniqueValueExample_bb.xls

  9. Ο/Η Leyteris λέει:

    ΕΥΧΑΡΙΣΤΩ ΠΟΛΥ για την άμεση απάντηση αλλά και για τον χρόνο που αφιέρωσες.Αρχίσω να καταλαβαίνω τις απεριόριστες δυνατότητες του excel και σίγουρα η βοήθεια σου είναι καθοριστικής σημασίας . Θα το δοκιμάσω και θα επανέλθω.

  10. Ο/Η vioannis λέει:

    Έτσι ακριβώς:απεριόριστες δυνατότητες του excel!

  11. Ο/Η θανασης λέει:

    Καλημέρα κύριε Γιάννη , ξέθαψα μετά από καιρό μια μακροεντολή που είχα , άλλαξα τις στήλες όπως με βόλευε και τη δούλεψα μερικές φορές , δυστυχώς κάποιο σφάλμα δημιουργήθηκε μετά από κάποια αποθήκευση και πλέον δε τρέχει , η παλιά τρέχει ακόμα σε excel 97-2003

    http://prntscr.com/3ckvhd

    εδώ είναι μια φώτο με το πρόβλημα

  12. Ο/Η vioannis λέει:

    Το UserForm1 που η προβληματική εντολή το καλεί να εμφανιστεί, υπάρχει; Μήπως κατά την εισαγωγή-του στο project έχει αλλάξει όνομα σε UserForm1(2) ή UserForm11 ή UserForm2; Τίποτα άλλο δεν βλέπω.

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