[Γενικά] Απορία για εύκολη εύρεση επαναλαμβανόμενων τιμών

[gpentez]

γεια παιδια κ χρονια πολλα .εχω μια απορια .θελω με καποιον τροπο με συναρτηση η αλλη ενεργεια να βρισκω ομοιες τιμες σε πχ 10 γραμμες ποιες τιμες επαναλαμβανονται κ αν γινεται να μη δινω συγκεκριμενη τιμη αλλα αυτοματα το προγραμμα να βρισκει τις ομοιες υπαρχει κ η ευρεση αλλα δεν ειναι ευχρηστη ειδικα οταν δουλευεις με πολλες τιμες επειδη το θεμα ειναι σημαντικο για μενα οποιος μπορει να με διαφωτισει .....μηπως αυτο που ζηταω μπορω να το πετυχω σε αλλο προγραμμα του οφις ? ευχαριστω πολυ

[Spirosgr]

Καλημέρα
Αυτά ισχύουν για επισήμανση και οχι κατάργηση διπλότυπων
Υπάρχουν διάφοροι τρόποι στο Συνημμένο
Ελπίζω να βοηθήσουν
Η Μακροεντολή είναι

Sub Find_Matches()
Dim CompareRange As Variant, x As Variant, y As Variant
' Set CompareRange equal to the range to which you will
' compare the selection.
Set CompareRange = Range("C1:C5")
' NOTE: If the compare range is located on another workbook
' or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2"). _
' Worksheets("Sheet2").Range("C1:C5")
'
' Loop through each cell in the selection and compare it to
' each cell in CompareRange.
For Each x In Selection
For Each y In CompareRange
If x = y Then x.Offset(0, 1) = x
Next y
Next x
End Sub


ΚΑΛΗ ΧΡΟΝΙΑ!!!

[gpentez]

ευχαριστω πολυ

[manolis]

Καλησπέρα σε όλη την παρέα

Εχω ένα αρχείο με 1100 εγγραφες. Οι στήλες είναι 29.
Καποιες γραμμες είναι ακριβως ίδιες και θα ΄ήθελα να τις επισημάνω.

Σκεφτόμουν μήπως με κάποια μετατροπή του κώδικα του Σπύρου μπορεί να γίνει αυτό.



Ευχαριστώ

[Spirosgr]

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


Πρόταση 1
Μετά την τελευταία στήλη, (στην 30 η) βάλε Concatenate και εντόπισε τα διπλότυπα,
με Conditional Formatting
Πρόταση 2
Έχοντας κάνει την πρώτη ενέργεια, μπορείς να:
Μετά την νέα τελευταία στήλη, (στην 31 η) βάλε CountIf και «μέτρα»,
ποια κελιά της 30 ης, είναι >1.
Με φίλτρο, ως προς >1, μπορείς να έχεις «πιάτο», μόνο τις διπλοεγγραφές.
Αποφασίζεις τότε, τι θα τις κάνεις...
Πρόταση 3
Ο παρακάτω κώδικας, για να μπορέσει να τρέξει, «θέλει» να ενεργοποιηθεί από το Tools >> References
το Microsoft Scripting Runtime.
Μερικές πληροφορίες:
Χρησιμοποιεί, διπλό χρωματισμό για:
Πρώτη εγγραφή (ΚΙΤΡΙΝΟ) - επόμενες διπλότυπες εγγραφές (ΠΡΑΣΙΝΟ)
*Τα χρώματα, μπορεί να αλλάξουν αν θέλει ο χρήστης.
Δεν υπολογίζει ως διπλότυπα, κενές γραμμές.
Σημείωση:
Το μικρό κωδικάκι επαναφέρει τα χρώματα σε ... «τίποτα».

Option Explicit
'Να ενεργοποιηθεί το Microsoft Scripting Runtime
'Tools >> References
Sub HighDupes()
    Dim iWSt As Worksheet
    Dim iRow As Range
    Dim iCol As Range
    Dim NewString As String
    Dim iDictionary As Dictionary
    Set iDictionary = New Dictionary
    Set iWSt = Sh1
    Application.ScreenUpdating = False
    For Each iRow In iWSt.UsedRange.Rows
        'Αν οι γραμμές είναι κενές (Blank Rows) τότε skip
        If Application.CountA(iWSt.Rows(iRow.Row)) > 0 Then
            NewString = "Ο_ΤΙΤΛΟΣ_ΤΟΥ_ΦΥΛΛΟΥ" 'ΧωρίςΚενά - εννοείται και στο φύλλο ...
            For Each iCol In iWSt.UsedRange.Columns
                NewString = NewString & "||" & iWSt.Cells(iRow.Row, iCol.Column)
            Next
            If iDictionary.exists(NewString) Then
                'Διπλός χρωματισμός: Πρώτης εγγραφής - επόμενων εγγραφών
                iWSt.Rows(iRow.Row).Interior.Color = vbYellow 'ΚΙΤΡΙΝΟ
                iWSt.Rows(iDictionary(NewString)).Interior.Color = vbGreen ' ΠΡΑΣΙΝΟ
            Else
                iDictionary.Add NewString, iRow.Row
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Set iDictionary = Nothing
    Set iWSt = Nothing
End Sub

'Επαναφορά χρωμάτων
Sub ColorReset()
    Application.ScreenUpdating = False
    ActiveSheet.Cells.Interior.Color = xlNone
End Sub

[kapetang]

Καλημέρα

Μανώλη, δες μια πρόταση στο συνημμένο.

Οι γραμμές των δεδομένων χωρίζονται σε δύο ομάδες (0) και (1).

Η ομάδα (0) περιλαμβάνει όλες τις διαφορετικές γραμμές.

Με άλλα λόγια στην ομάδα αυτή κάθε γραμμή είναι μοναδική και διαφέρει από όλες τις άλλες γραμμές τις ομάδες.

Η ομάδα (1) περιλαμβάνει τις υπόλοιπες γραμμές.

Δηλαδή κάθε γραμμή στην ομάδα αυτή εκπροσωπείται στην ομάδα (0) και συνεπώς θα μπορούσε να διαγραφεί.

Περισσότερα για την επισήμανση των ομάδων και τη διαγραφή των γραμμών (περιττών) της ομάδας (1), στο συνημμένο.

Φιλικά/Γιώργος

[manolis]

Καλησπέρα σε όλη την παρέα

Πριν απο όλα θα ήθελα να ζητήσω συγγνώμη που δεν ανέβασα κάποιο παράδειγμα.

Σπύρο και Γιώργο σας ευχαριστώ πολύ για τις λύσεις που μου προτείνατε.

Επειδή με με πίεζε ο χρόνος δεν προλαβαινα να τις κοιτάξω όλες,

Επειδή μου φάνηκε πιο ευκολη , χρησιμοποίησα την λύση με την Concatenate και πήρα το αποτέλεσμα που ήθελα.

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

Με εκτίμηση