[VBA] Κατάργηση διπλοτύπων

[Mpampis9050]

Αγαπητοί φίλοι του Forum, επανέρχομαι στη βοήθεια σας για συμπλήρωση (γραμμής ;) κώδικα όπου στη στήλη (stili1) του επισυναπτόμενου αρχείου θα αφαιρούνται οι διπλότυπες εγγραφές.
Προσπάθησα να περάσω τη γραμμή που φαίνεται με κίτρινο στη φωτό αλλά βγάζει error.
Δεν θέλω να γίνεται με μακροεντολή, αλλά αν μπορούσε να γίνεται αυτόματα με την εκτέλεση της υπάρχουσας ρουτίνας.
Σας ευχαριστώ.

[kapetang]

Καλησπέρα

Μπάμπη, δεν καταλαβαίνω ούτε τι θέλεις, ούτε τον κώδικα.

Πάντως για να μη χτυπάει ο κώδικας αντικατέστησε τη γραμμή με την:

Φύλλο2.Range("Πίνακας1[#All]").RemoveDuplicates

[Mpampis9050]

Ευχαριστώ για την άμεση απάντηση φίλε Kapatang , η πρόταση σου δούλεψε εν μέρη γιατί πρέπει να κλικάρεις στο Φύλλο2 (οπουδήποτε) για να εφαρμοστεί το "RemoveDuplicates" δεν γίνεται δηλαδή αυτόματα. Επισυνάπτω πάλι το αρχείο

[kapetang]

Καλησπέρα

Φίλε Μπάμπη μάλλον έχεις μπερδευτεί.

Στο φύλλο «Φύλλο2» έχεις μία λίστα τιμών και θέλεις:

1) Στο φύλλο1 και στη στήλη C να επιλέγεις μία τιμή της λίστας.

2) Η επιλεγείσα τιμή να προστίθεται στη λίστα του φίλλου2 (από την οποία έχει επιλεχθεί) και

3) Αυτόματα να απομακρύνονται από τη λίστα του φύλλο2 οι διπλότυπες τιμές.

Όπως καταλαβαίνεις θα δημιουργηθεί ένας φαύλος κύκλος.

Μόλις η επιλεγείσα τιμή προστεθεί στη λίστα του φύλλο2, θα διαγραφεί, αφού θα δημιουργήσει διπλότυπες τιμές.

Έχω τη γνώμη ότι θα πρέπει να ξανασκεφτείς το πρόβλημά σου και να το περιγράψεις με σαφήνεια.

[Mpampis9050]

Μάλλον δεν έγινα σαφής. Το αρχείο δουλεύει κανονικά όπως θέλω. Το μόνο πρόβλημα είναι να καταργούνται οι διπλότυπες εγγραφές (αν υπάρχουν) αυτόματα από τη λίστα του Φύλλου2, χωρίς να χρειάζεται να κλικάρω οπουδήποτε στο Φύλλο2 ... (ημιαυτόματα, δηλαδή με κλικ οπουδήποτε, γίνεται)

[Spirosgr]

Το αρχείο, δεν δουλεύει σωστά.

Στο φύλλο2, δεν χρειάζεται καμία εντολή και πρέπει να διαγραφεί.
Στο φύλλο1, έχεις αντιγράψει κομμάτια κώδικα, που δεν είναι σωστά.

Τι θα πρέπει να κάνεις.
Στο φύλλο1:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Rows.Count > 1 Then Exit Sub
    If Target.Columns.Count > 1 Then Exit Sub
    If Target.Column <> 3 Then Exit Sub
    If Target.Value = vbNullString Then Exit Sub

    Dim Lrow As Long
    Lrow = Φύλλο2.ListObjects("Πίνακας1").ListRows.Count + 1
    
    Φύλλο2.Cells(Lrow + 1, 1).Value = Target.Value
    Φύλλο2.Range("Πίνακας1[#All]").RemoveDuplicates Columns:=1, Header:=xlYes
'    iSort
End Sub

Αν θέλουμε στο φύλλο2, οι τιμές, να είναι και αλφαβητικά ταξινομημένες, τότε
σε μια module:

Sub iSort()
    Φύλλο2.ListObjects("Πίνακας1").Sort.SortFields. _
        Clear
    Φύλλο2.ListObjects("Πίνακας1").Sort.SortFields. _
        Add Key:=Range("Πίνακας1[[#All],[stili1]]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortNormal
    With Φύλλο2.ListObjects("Πίνακας1").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

και ενεργοποιούμε την προτελευταία γραμμή (πράσινο)

Στην Επικύρωση (validation)...βλέπε εικόνες 1,2

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

[Mpampis9050]

Μετά και από τις προσθήκες κώδικα από τον Spirosgr το αρχείο δουλεύει τέλεια όπως ήθελα, δηλαδή όχι μόνο αντιγραφή και ενημέρωση κελιών στήλης από ένα Φύλλο στο άλλο, αλλά και κατάργηση διπλοτύπων και φυσικά ταξινόμηση.
Θερμές ευχαριστίες στους κορυφαίους Kapetang και Spirosgr για την άμεση ανταπόκριση και καθοδήγηση τους.

[Spirosgr]

Να 'σαι καλά.