Forum - Συναρτήσεις αυτόματη κατάργηση διπλότυπων

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [Συναρτήσεις] αυτόματη κατάργηση διπλότυπων (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/4691-aytomati-katargisi-diplotypon.html)

αυτόματη κατάργηση διπλότυπων

Καλή σας μέρα,
Χρειάζομαι μια μικρή βοήθεια.
Επιθυμώ να φέρω μοναδικές εγγραφές από διαφορετικά φύλλα
σε ένα συγκεντρωτικό.
Μέχρι τώρα έκανα τα εξής.

1. Αντιγραφή από όλα τα φύλλα
2. Επικόλληση στο κεντρικό
3. Ταξινόμηση
4. Κατάργηση διπλότυπων.

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

Ευχαριστώ.

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

Κώδικας:

Sub Combine()

    Dim sh As Worksheet _

      , Lrow As Long, Nrow As Long _

      , Rng As Range, tRng As Range _

      , i As Long
 

    Application.ScreenUpdating = False
 

    Lrow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row

    Set Rng = Sheet1.Range("b7:b" & Lrow)
 

    If Lrow = 6 Then GoTo cnt_Here:
 

    Rng.ClearContents
 

cnt_Here:

    For i = 2 To ThisWorkbook.Sheets.Count

        Lrow = 0

        Nrow = 0

        Lrow = Sheets(i).Cells(Rows.Count, 2).End(xlUp).Row

        Nrow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row + 1

        Sheets(i).Range("b7:b" & Lrow).Copy _

                Destination:=Sheet1.Cells(Nrow, 2)

    Next i
 

    Lrow = 0

    Lrow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row

    Set tRng = Sheet1.Range("b7:b" & Lrow)
 

    tRng.RemoveDuplicates Columns:=1, Header:=xlYes

    

    Sheet1.Sort.SortFields.Clear

    Sheet1.Sort.SortFields.Add Key:=tRng, _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With Sheet1.Sort

        .SetRange tRng

        .Header = xlNo

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With
 

End Sub

Σημειώσεις:
Ο κώδικας, μεταφέρει τις εγγραφές από όλα τα (ν) φύλλα του βιβλίου, στο Total.

Κατόπιν, διαγράφει τα διπλότυπα και ταξiνομεί Α-Ω ή Α-Ζ

Το φύλλο Total, θα πρέπει να παραμείνει με κωδικό όνομα = Sheet1 και
πάντα στην πρώτη θέση του βιβλίου.

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

Το βιβλίο, θα πρέπει να αποθηκευτεί, ως .xlsm

Καλησπέρα

Αντώνη δες μια υλοποίηση, με κώδικα VBA, στο συνημμένο.

Γιώργο, ο κώδικάς σου, έχει ένα σφάλμα.

Ξεκινώντας θα πρέπει να καθαρίζει την περιοχή στο Total, διότι αν
για παράδειγμα έχουμε 100 εγγραφές και μετά την ανανέωση έχουμε 90
θα παραμείνουν 10 εγγραφές που δεν πρέπει...

Ευχαριστώ πολύ για άλλη μια φορά για την βοήθεια. :thumbup: :thumbup:

Σπύρο δεν υπάρχει λάθος.

Οι εγγραφές που θα καταλήξουν στο φύλλο "Total" είναι i.

Πριν από την αντιγραφή τους καθαρίζονται i+5, γραμμές.

Έτσι ανάμεσα στα νέα δεδομένα και στα τυχόν παλιά θα υπάρχουν, για διάκριση, 5 κενές γραμμές.

Γράψε στο φύλλο 100, κάτω από το Belarus πχ Hellas και από κάτω ότι να ναι πχ ΧΧΧΧ
Εκτέλεσε τον κώδικα.
Σβήσε τα πιο πάνω από το φύλλο 100 και εκτέλεσε πάλι...

Σπύρο έχεις δίκιο, αλλά το λάθος είναι ότι στον κώδικα αντί:

rng.Resize(i + 5).ClearContents, από αβλεψία έγγραψα:

rng.Resize(i + 5).ClearComments

Ok, όλα καλά!