Note: The other languages of the website are Google-translated. Back to English

Πώς να επισημάνετε διπλές τιμές σε διαφορετικά χρώματα στο Excel;

doc διαφορετικά χρώματα αντίγραφα 1

Στο Excel, μπορούμε εύκολα να επισημάνουμε τις διπλές τιμές σε μια στήλη με ένα χρώμα χρησιμοποιώντας το Μορφοποίηση υπό όρους, αλλά, μερικές φορές, πρέπει να επισημάνουμε τις διπλές τιμές σε διαφορετικά χρώματα για να αναγνωρίσουμε τα διπλά γρήγορα και εύκολα όπως φαίνεται στο παρακάτω στιγμιότυπο οθόνης. Πώς θα μπορούσατε να επιλύσετε αυτήν την εργασία στο Excel;

Επισημάνετε τις διπλές τιμές σε μια στήλη με διαφορετικά χρώματα χρησιμοποιώντας τον κώδικα VBA


βέλος μπλε δεξιά φούσκα Επισημάνετε τις διπλές τιμές σε μια στήλη με διαφορετικά χρώματα χρησιμοποιώντας τον κώδικα VBA

Στην πραγματικότητα, δεν υπάρχει άμεσος τρόπος για να ολοκληρώσουμε αυτήν την εργασία στο Excel, αλλά, ο παρακάτω κώδικας VBA μπορεί να σας βοηθήσει, κάντε τα εξής:

1. Επιλέξτε τη στήλη τιμών που θέλετε να επισημάνετε διπλότυπα με διαφορετικά χρώματα και, στη συνέχεια, κρατήστε πατημένο το ALT + F11 για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

2. Πατήστε Κύριο θέμα > Μονάδα μέτρησηςκαι επικολλήστε τον ακόλουθο κώδικα στο Μονάδα μέτρησης Παράθυρο.

Κωδικός VBA: Επισημάνετε διπλές τιμές σε διαφορετικά χρώματα:

Sub ColorCompanyDuplicates()
'Updateby Extendoffice
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xChar As String
    Dim xCellPre As Range
    Dim xCIndex As Long
    Dim xCol As Collection
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
    Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    xCIndex = 2
    Set xCol = New Collection
    For Each xCell In xRg
      On Error Resume Next
      xCol.Add xCell, xCell.Text
      If Err.Number = 457 Then
        xCIndex = xCIndex + 1
        Set xCellPre = xCol(xCell.Text)
        If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
        xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
      ElseIf Err.Number = 9 Then
        MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
        Exit Sub
      End If
      On Error GoTo 0
    Next
End Sub

3. Και στη συνέχεια πατήστε F5 για να εκτελέσετε αυτόν τον κωδικό και ένα πλαίσιο προτροπής θα σας υπενθυμίσει να επιλέξετε το εύρος δεδομένων που θέλετε να επισημάνετε τις διπλές τιμές, δείτε το στιγμιότυπο οθόνης:

doc διαφορετικά χρώματα αντίγραφα 2

4. Στη συνέχεια κάντε κλικ στο κουμπί OK κουμπί, όλες οι διπλές τιμές έχουν επισημανθεί σε διαφορετικά χρώματα, δείτε το στιγμιότυπο οθόνης:

doc διαφορετικά χρώματα αντίγραφα 1


Τα καλύτερα εργαλεία παραγωγικότητας του Office

Kutools for Excel Λύνει τα περισσότερα από τα προβλήματά σας και αυξάνει την παραγωγικότητά σας κατά 80%

  • Επαναχρησιμοποίηση: Εισαγάγετε γρήγορα σύνθετοι τύποι, γραφήματα και οτιδήποτε έχετε χρησιμοποιήσει στο παρελθόν. Κρυπτογράφηση κυττάρων με κωδικό πρόσβασης Δημιουργία λίστας αλληλογραφίας και στείλτε email ...
  • Super Formula Bar (επεξεργαστείτε εύκολα πολλές γραμμές κειμένου και τύπου). Διάταξη ανάγνωσης (εύκολη ανάγνωση και επεξεργασία μεγάλου αριθμού κελιών). Επικόλληση σε φιλτραρισμένο εύρος...
  • Συγχώνευση κελιών / σειρών / στηλών χωρίς απώλεια δεδομένων · Περιεχόμενο διαχωρισμού κελιών Συνδυάστε διπλές σειρές / στήλες... Αποτροπή διπλών κυττάρων; Συγκρίνετε τα εύρη...
  • Επιλέξτε Διπλότυπο ή Μοναδικό Σειρές; Επιλέξτε Κενές σειρές (όλα τα κελιά είναι κενά). Σούπερ εύρεση και ασαφής εύρεση σε πολλά βιβλία εργασίας. Τυχαία επιλογή ...
  • Ακριβές αντίγραφο Πολλαπλά κελιά χωρίς αλλαγή της αναφοράς τύπου. Αυτόματη δημιουργία αναφορών σε πολλαπλά φύλλα? Εισαγωγή κουκκίδων, Πλαίσια ελέγχου και άλλα ...
  • Εξαγωγή κειμένου, Προσθήκη κειμένου, Κατάργηση κατά θέση, Αφαιρέστε το διάστημα; Δημιουργία και εκτύπωση υποσύνολων σελιδοποίησης. Μετατροπή περιεχομένου και σχολίων μεταξύ κελιών...
  • Σούπερ φίλτρο (αποθηκεύστε και εφαρμόστε σχήματα φίλτρων σε άλλα φύλλα). Προηγμένη ταξινόμηση ανά μήνα / εβδομάδα / ημέρα, συχνότητα και άλλα. Ειδικό φίλτρο με έντονη, πλάγια ...
  • Συνδυάστε βιβλία εργασίας και φύλλα εργασίας; Συγχώνευση πινάκων βάσει βασικών στηλών. Διαχωρίστε τα δεδομένα σε πολλά φύλλα; Μαζική μετατροπή xls, xlsx και PDF...
  • Περισσότερα από 300 ισχυρά χαρακτηριστικά. Υποστηρίζει Office / Excel 2007-2021 και 365. Υποστηρίζει όλες τις γλώσσες. Εύκολη ανάπτυξη στην επιχείρηση ή τον οργανισμό σας. Πλήρεις δυνατότητες δωρεάν δοκιμής 30 ημερών. Εγγύηση επιστροφής χρημάτων 60 ημερών.
kte καρτέλα 201905

Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
κάτω μέρος γραφείου
Σχόλια (91)
Δεν υπάρχουν ακόμη βαθμολογίες. Γίνε ο πρώτος που θα αξιολογήσετε!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Μου λειτούργησε σε μια λίστα με αριθμούς ανταλλακτικών.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.

Υπάρχει τρόπος να γίνει αυτό το αποτέλεσμα μόνο στην επισημασμένη στήλη και όχι σε ολόκληρη τη σειρά; Μερικά από τα έντονα κόκκινα και μπλε χρώματα είναι δύσκολο να τα δούμε σε όλο το υπολογιστικό φύλλο. Ευχαριστώ
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό ακριβώς χρειαζόμουν, ευχαριστώ. Μερικές φορές, όταν εκτελώ αυτόν τον κώδικα, το Excel απλώς παγώνει, χρησιμοποιώ το Office 2016 / Windows 10, έχω ιδέα γιατί;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Πάτρικ, επισήμανε μόνο τα κελιά που θέλεις. Μην επισημάνετε ολόκληρη τη στήλη που θα περιλαμβάνει και τα χιλιάδες κενά κελιά
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Θέλω να ελέγξω τα διπλότυπα για 5000 κελιά, κάτι που δεν μπορώ να κάνω. μπορώ να επισημάνω διπλότυπα έως και 70 έως 80 κελιά
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Sub BuscarD()
Dim xRg ως εύρος
Dim xTxt ως συμβολοσειρά
Dim xCell ως εύρος
Dim xChar ως συμβολοσειρά
Dim xCellPre As Range
Dim xCol As Collection
Dim I As Long
Dim J ως ακέραιος αριθμός
Dim K ως ακέραιος αριθμός
Dim xCLR ως ακέραιος

xCLR = 28

On Error Συνέχιση Επόμενη
Εάν ActiveWindow.RangeSelection.Count > 1 Τότε
xTxt = ActiveWindow.RangeSelection.AddressLocal
Αλλού
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Seleccione el rango a evaluar:", "Buscar duplicados", xTxt, , , , , 8)
Εάν το xRg δεν είναι τίποτα, τότε βγείτε από το Sub
J=0
Κ = 0
Ορισμός xCol = Νέα συλλογή
Για κάθε xCell σε xRg
On Error Συνέχιση Επόμενη
xCol.Add xCell, xCell.Text
Αν Σφάλμα.Αριθμός = 457 Τότε
Ορισμός xCellPre = xCol(xCell.Text)
Αν xCellPre.Interior.ColorIndex = xlΚαμία Τότε
xCellPre.Interior.Color = RGB(255, J, K)
xCell.Interior.Color = RGB(255, J, K)
Αν K + xCLR <= 255 Τότε
K = K + xCLR
Αλλού
Αν J + xCLR <= 255 Τότε
Κ = 0
J = J + xCLR
Αλλού
MsgBox "!Demasiados datos duplicados!: Reducir variable xCLR", vbCritical, "Error"
Έξοδος Sub
End If
End If
Αλλού
xCell.Interior.Color = xCellPre.Interior.Color
End If
ElseIf Err.Number = 9 Τότε
MsgBox "Demasiados datas duplicados!", vbCritical, "Error"
Έξοδος Sub
End If
Στο σφάλμα GoTo 0
Επόμενο

Sub End

Es un tema viejo, pero lo dejo por si alguien lo necesita. Con el codigo anterior y modificando la variable "xCLR", desde 1 a 255, se pueden obtener desde 4 hasta 65.000 διαφορετικά χρώματα. En mi caso, configuré el rojo del RGB con un valor estático de 255 y varío los valores verde y azul (255, X, X). Si se requieren mas colores, se podría alterar el valor del rojo, logrando mas de 166 millones de colores diferentes
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό ήταν μια ζωή για μένα, σας ευχαριστώ πολύ που το μοιραστήκατε! Όταν το εκτελώ σε περίπου 2000 κελιά με τιμές, επισημαίνει μόνο μερικά από τα διπλότυπα. Υπάρχει τρόπος να το διορθώσω; Αναρωτιέμαι αν ξεμείνει από χρώματα ή υπάρχει κάτι άλλο.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
το ίδιο πρόβλημα προσπαθώ με μερικές εκατοντάδες κελιά και πολύ γρήγορα χρωματίζεται στα ίδια χρώματα. υπάρχει λύση για αυτό; ευχαριστώ
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Το ιδιο ΠΡΟΒΛΗΜΑ. Το ανακάλυψε κανείς αυτό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Είχα το ίδιο πρόβλημα, το πρόβλημα είναι ότι ο δείκτης χρώματος πηγαίνει μόνο στο 56, οπότε μόλις περάσει δεν χρωματίζει πλέον τα κελιά. Για να το διορθώσω, αντικατέστησα τη γραμμή "xCIndex = xCIndex + 1" με το εξής: Αν xCIndex > 55 Τότε xCIndex = 3 Διαφορετικά xCIndex = xCIndex + 1 Τέλος Εάν τελικά θα αρχίσει να επαναχρησιμοποιεί χρώματα, αλλά αυτό δεν ήταν πρόβλημα για μου.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αντικαταστήστε με Αν xCIndex > 55 Τότε xCIndex = 3 Διαφορετικά xCIndex = xCIndex + 1 Τέλος εάν δεν λειτούργησε. Προσπαθώ να το κάνω αυτό να λειτουργήσει σε 14000 γραμμές, περίπου 6000 διπλότυπα
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Μου δούλεψε, έκανα εσοχή τη δεύτερη και την τέταρτη γραμμή. Δες παρακάτω. Ο κώδικας του Τζος είναι έντονος.

Αν Σφάλμα.Αριθμός = 457 Τότε
Αν xCIndex > 55 Τότε
xCIndex = 3
Αλλού
xCIndex = xCIndex + 1
End If
Ορισμός xCellPre = xCol(xCell.Text)
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ευχαριστώ πολύ Josh, λειτουργεί!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό λειτούργησε ΤΕΛΕΙΑ!! Ευχαριστώ. Έχανα το μυαλό μου προσπαθώντας να βρω μια λύση. Σε εκτιμώ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Προσπάθησα να το εκτελέσω αρκετές φορές και κάθε φορά που κάνω κλικ στο "ok" απλώς με στέλνει πίσω στην οθόνη των μονάδων. Χρησιμοποιώ το Excel 2010.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό είναι υπέροχο και ΑΚΡΙΒΩΣ αυτό που έψαχνα! Ενσωματώνω αυτόν τον κώδικα σε κάποιον υπάρχοντα κώδικα - έχω γράψει τον κωδικό μου για να επιλέξω τα κελιά που θέλω να χρωματίσω και, στη συνέχεια, καλώ τον κωδικό για να κάνω το χρωματισμό. Το μόνο πράγμα που δεν μπορώ να καταλάβω είναι πώς να παρακάμψω το msgBox που εμφανίζεται και πρέπει να κάνω κλικ στο OK. Είμαι αρχάριος στο VBA και δεν μπορώ να καταλάβω πώς να αλλάξω αυτόν τον κώδικα... Οποιεσδήποτε προτάσεις, παρακαλώ! :)
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αντικατάσταση γραμμής: Set xRg = Application.InputBox("παρακαλώ επιλέξτε το εύρος δεδομένων:", "Kutools for Excel", xTxt, , , , , 8)
προς την
Ορισμός xRg = Εύρος ("A1:A100")

ή αν έχετε πίνακα, μπορείτε να κάνετε αίτηση για ολόκληρη τη στήλη του πίνακα:
Ορισμός xRg = Εύρος ("Πίνακας1[[#Όλα],[Στήλη1]]")

Απλώς αντικαταστήστε τον Πίνακα1 με το όνομά σας και τη Στήλη1 σε οποιαδήποτε κεφαλίδα πίνακα θέλετε να εφαρμόσετε αυτήν τη μακροεντολή.


Χαιρετισμούς
Wojciech
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Είμαι πολύ χαρούμενος καθώς πήρα αυτό που χρειαζόμουν. Ευχαριστώ
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
πως αλλαζω χρωμα?
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια,
Ο κωδικός μόνο μπορεί να σας βοηθήσει να προσθέσετε το διαφορετικό χρώμα τυχαία, δεν μπορεί να αλλάξει το χρώμα.
Ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ωστόσο, φαίνεται να χρησιμοποιεί πάντα την ίδια χρωματική παλέτα, υπάρχει τρόπος να επιλέξετε την παλέτα που χρησιμοποιεί; Μου δίνει μερικά πραγματικά σκούρα χρώματα μέσα από τα οποία το κείμενο είναι αδιάβαστο.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
το ίδιο πρόβλημα με εμένα... το χρώμα είναι πολύ σκούρο για να το διαβάσω...
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
χωρίς άδειο να αλλάξω χρώμα πώς ?????????????????????
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου, gopi,
Για να αποφύγετε τα κενά κελιά, εφαρμόστε τον ακόλουθο κώδικα VBA:
Sub ColorCompanyDuplicates()
'Ενημέρωση Extendoffice 20171222
Dim xRg ως εύρος
Dim xTxt ως συμβολοσειρά
Dim xCell ως εύρος
Dim xChar ως συμβολοσειρά
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Συνέχιση Επόμενη
Εάν ActiveWindow.RangeSelection.Count > 1 Τότε
xTxt = ActiveWindow.RangeSelection.AddressLocal
Αλλού
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("παρακαλώ επιλέξτε το εύρος δεδομένων:", "Kutools for Excel", xTxt, , , , , 8)
Εάν το xRg δεν είναι τίποτα, τότε βγείτε από το Sub
xCIndex = 2
Ορισμός xCol = Νέα συλλογή
Για κάθε xCell σε xRg
On Error Συνέχιση Επόμενη
Αν xCell.Value <> "" Τότε
xCol.Add xCell, xCell.Text
Αν Σφάλμα.Αριθμός = 457 Τότε
xCIndex = xCIndex + 1
Ορισμός xCellPre = xCol(xCell.Text)
Αν xCellPre.Interior.ColorIndex = xlNone Τότε xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Τότε
MsgBox "Υπερβολικά πολλές διπλότυπες εταιρείες!", vbCritical, "Kutools for Excel"
Έξοδος Sub
End If
Στο σφάλμα GoTo 0
End If
Επόμενο
Sub End

Ελπίζω ότι μπορεί να σας βοηθήσει, σας ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Κύριε,
Πώς να διαφοροποιήσετε τα διαφορετικά χρώματα που δίνονται στα δεδομένα με βάση τη συχνότητα;
Σε πολύ μεγάλα δεδομένα το ίδιο χρώμα έχει δοθεί επανειλημμένα χωρίς να λαμβάνεται υπόψη η συχνότητά τους.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Λυπούμαστε, μπορείτε να δώσετε πιο λεπτομερείς πληροφορίες, μπορείτε να επισυνάψετε ένα στιγμιότυπο οθόνης εδώ.
Ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, έχω το Excel 2016, το alt+F11 λειτουργεί πια για να εμφανιστεί το Microsoft VB; είναι το Microsoft Visual Basic ελεύθερο λογισμικό; Σας ευχαριστώ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,
Εάν δεν μπορείτε να ενεργοποιήσετε το παράθυρο Microsoft VB κρατώντας πατημένα τα πλήκτρα Alt + F11, μπορείτε να κάνετε κλικ στην επιλογή Προγραμματιστής > Visual Basic για να το ανοίξετε.

Δοκιμάστε το, σας ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Τι γίνεται αν θέλω να γεμίσω μόνο με δύο χρώματα, ας πούμε το κίτρινο και το κόκκινο, επανειλημμένα. Για να είμαστε σαφείς, στο παράδειγμα αυτής της σελίδας, το 'Rachel' είναι κίτρινο, το Rose είναι κόκκινο και πάλι η Sussies είναι κίτρινη, ο Tedi είναι κόκκινος.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Σελίμ,
Ο παρακάτω κώδικας μπορεί να λύσει το πρόβλημά σας, δοκιμάστε.

Sub ColorCompanyDuplicates()
'Ενημέρωση Extendoffice 20170504
Dim xRg ως εύρος
Dim xTxt ως συμβολοσειρά
Dim xCell ως εύρος
Dim xChar ως συμβολοσειρά
Dim xCellPre As Range
Dim xRgTemp ως εύρος
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Συνέχιση Επόμενη
Εάν ActiveWindow.RangeSelection.Count > 1 Τότε
xTxt = ActiveWindow.RangeSelection.AddressLocal
Αλλού
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("παρακαλώ επιλέξτε το εύρος δεδομένων:", "Kutools for Excel", xTxt, , , , , 8)
Εάν το xRg δεν είναι τίποτα, τότε βγείτε από το Sub
xCIndex = 3
Ορισμός xCol = Νέα συλλογή
Για κάθε xCell σε xRg
On Error Συνέχιση Επόμενη
xCol.Add xCell, xCell.Text
Αν Σφάλμα.Αριθμός = 457 Τότε
Ορισμός xCellPre = xCol(xCell.Text)
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Τότε
MsgBox "Υπερβολικά πολλές διπλότυπες εταιρείες!", vbCritical, "Kutools for Excel"
Έξοδος Sub
Αλλού
xCell.Interior.ColorIndex = xCIndex
Ορίστε xRgTemp = xCell
xCIndex = IIf(xRgTemp.Interior.ColorIndex = 3, 4, 3)
End If
Στο σφάλμα GoTo 0
Επόμενο
Sub End

Ελπίζω ότι μπορεί να σας βοηθήσει!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό ακριβώς το θέλω. Ευχαριστώ πολύ, skyyang.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Υπάρχει τρόπος να επισημάνετε ολόκληρη τη σειρά αντί για 1 στήλη;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, Bobo,
Για να επισημάνετε ολόκληρη τη σειρά με βάση τις διπλότυπες τιμές κελιών, μπορείτε να εφαρμόσετε τον ακόλουθο κώδικα VBA:

Sub ColorCompanyDuplicates()
Dim xRg ως εύρος
Dim xTxt ως συμβολοσειρά
Dim xCell ως εύρος
Dim xChar ως συμβολοσειρά
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Συνέχιση Επόμενη
Εάν ActiveWindow.RangeSelection.Count > 1 Τότε
xTxt = ActiveWindow.RangeSelection.AddressLocal
Αλλού
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("παρακαλώ επιλέξτε το εύρος δεδομένων:", "Kutools for Excel", xTxt, , , , , 8)
Εάν το xRg δεν είναι τίποτα, τότε βγείτε από το Sub
xCIndex = 2
Ορισμός xCol = Νέα συλλογή
Για κάθε xCell σε xRg
On Error Συνέχιση Επόμενη
xCol.Add xCell, xCell.Text
Αν Σφάλμα.Αριθμός = 457 Τότε
xCIndex = xCIndex + 1
Ορισμός xCellPre = xCol(xCell.Text)
Αν xCellPre.Interior.ColorIndex = xlNone Τότε xCellPre.EntireRow.Interior.ColorIndex = xCIndex
xCell.EntireRow.Interior.ColorIndex = xCellPre.EntireRow.Interior.ColorIndex
ElseIf Err.Number = 9 Τότε
MsgBox "Υπερβολικά πολλές διπλότυπες εταιρείες!", vbCritical, "Kutools for Excel"
Έξοδος Sub
End If
Στο σφάλμα GoTo 0
Επόμενο
Sub End

Δοκιμάστε το, ελπίζω να σας βοηθήσει!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
πώς μπορώ να επισημάνω το εύρος των σειρών;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου, Hossein,
Ίσως ο παρακάτω κώδικας μπορεί να σας κάνει τη χάρη, δοκιμάστε τον.

Sub ColorCompanyDuplicates()
'Ενημέρωση Extendoffice
Dim xRg, xRgRow As Range
Dim xTxt, xStr ως συμβολοσειρά
Dim xCell, xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
Εάν ActiveWindow.RangeSelection.Count > 1 Τότε
xTxt = ActiveWindow.RangeSelection.AddressLocal
Αλλού
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("παρακαλώ επιλέξτε το εύρος δεδομένων:", "Kutools for Excel", xTxt, , , , , 8)
Εάν το xRg δεν είναι τίποτα, τότε βγείτε από το Sub
xCIndex = 2
Ορισμός xCol = Νέα συλλογή
Για I = 1 To xRg.Rows.Count
On Error Συνέχιση Επόμενη
Ορισμός xRgRow = xRg.Rows(I)
Για κάθε xCell σε xRgRow.Columns
xStr = xStr & xCell.Text
Επόμενο
xCol.Add xRgRow, xStr
Αν Σφάλμα.Αριθμός = 457 Τότε
xCIndex = xCIndex + 1
Ορισμός xCellPre = xCol(xStr)
Αν xCellPre.Interior.ColorIndex = xlNone Τότε xCellPre.Interior.ColorIndex = xCIndex
xRgRow.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Τότε
MsgBox "Υπερβολικά πολλές διπλότυπες εταιρείες!", vbCritical, "Kutools for Excel"
Έξοδος Sub
End If
Στο σφάλμα GoTo 0
xStr = ""
Επόμενο
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Φοβερο!! Αυτό με βοήθησε πολύ!
Και αν χρειαστεί να επισημάνω και τα single; Πως μπορώ να το κάνω αυτό?
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Κάρλα

Για να επισημάνετε τις σειρές που περιλαμβάνουν τις μοναδικές, εφαρμόστε τον παρακάτω κώδικα VBA:
Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg, xRgRow As Range
Dim xTxt, xStr As String
Dim xCell, xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim xOnlyIndex
Dim I As Long
If ActiveWindow.RangeSelection.Count > 1 Then
    xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
    xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For I = 1 To xRg.Rows.Count
    On Error Resume Next
    Set xRgRow = xRg.Rows(I)
    For Each xCell In xRgRow.Columns
        xStr = xStr & xCell.Text
    Next
    xCol.Add xRgRow, xStr
    If err.Number = 457 Then
        xCIndex = xCIndex + 1
        Set xCellPre = xCol(xStr)
        If xCellPre.Interior.ColorIndex = xlNone Then
            xCellPre.Interior.ColorIndex = xCIndex
        Else            
        End If
        xRgRow.Interior.ColorIndex = xCellPre.Interior.ColorIndex
    ElseIf err.Number = 9 Then
        MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
        Exit Sub
    End If    
    On Error GoTo 0
    xStr = ""
Next
For Each xCellPre In xCol
    If xCellPre.Interior.ColorIndex = xlNone Then
        xCIndex = xCIndex + 1
        xCellPre.Interior.ColorIndex = xCIndex
    End If
Next
End Sub

Παρακαλώ δοκιμάστε, ελπίζω ότι μπορεί να σας βοηθήσει!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ναι skyyang! Ροκ! 😀
Μπορούμε να επισημάνουμε ολόκληρη τη σειρά αντί μόνο τη στήλη;

Συγγνώμη αν ενοχλώ, αλλά πραγματικά με βοήθησες πολύ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Καρία,
Εάν πρέπει να επισημάνετε ολόκληρες τις σειρές, πρέπει απλώς να επιλέξετε ολόκληρο το εύρος των σειρών όταν επιλέγετε το εύρος δεδομένων στο αναδυόμενο παράθυρο διαλόγου.
Παρακαλώ δοκιμάστε, ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Συγγνώμη, δεν μπορώ 😟
Νομίζω ότι δεν είναι σωστό γιατί ο κώδικας λειτουργεί στη στήλη και όταν επιλέγω τις σειρές, επισημαίνονται, αλλά δεν ακολουθεί το προηγούμενο κριτήριο.

Ο κώδικας που μοιραστήκατε νωρίτερα, μόνο για διπλότυπα, λειτουργεί τέλεια.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Υπάρχει τρόπος να αλλάξετε το σενάριο ώστε να λειτουργεί για (κοιτάξτε) πίνακα πίνακα αντί για στήλη; Για παράδειγμα F2:BC117.
Ευχαριστώ!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Βασίλη,
Για να επισημάνετε διπλότυπες τιμές σε μια περιοχή κελιών, δοκιμάστε τον ακόλουθο κώδικα vba:

Sub ColorCompanyDuplicates()
'Ενημέρωση Extendoffice
Dim xRg, xRgRow As Range
Dim xTxt, xStr ως συμβολοσειρά
Dim xCell, xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
Εάν ActiveWindow.RangeSelection.Count > 1 Τότε
xTxt = ActiveWindow.RangeSelection.AddressLocal
Αλλού
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("παρακαλώ επιλέξτε το εύρος δεδομένων:", "Kutools for Excel", xTxt, , , , , 8)
Εάν το xRg δεν είναι τίποτα, τότε βγείτε από το Sub
xCIndex = 2
Ορισμός xCol = Νέα συλλογή
Για I = 1 To xRg.Rows.Count
On Error Συνέχιση Επόμενη
Ορισμός xRgRow = xRg.Rows(I)
Για κάθε xCell σε xRgRow.Columns
xStr = xStr & xCell.Text
Επόμενο
xCol.Add xRgRow, xStr
Αν Σφάλμα.Αριθμός = 457 Τότε
xCIndex = xCIndex + 1
Ορισμός xCellPre = xCol(xStr)
Αν xCellPre.Interior.ColorIndex = xlNone Τότε xCellPre.Interior.ColorIndex = xCIndex
xRgRow.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Τότε
MsgBox "Υπερβολικά πολλές διπλότυπες εταιρείες!", vbCritical, "Kutools for Excel"
Έξοδος Sub
End If
Στο σφάλμα GoTo 0
xStr = ""
Επόμενο
Sub End

Ελπίζω ότι μπορεί να σας βοηθήσει.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Είμαι νέος στο VBA. Υπάρχει κάποιος τρόπος, ώστε να μην χρειάζεται να εκτελούμε τη μακροεντολή ξανά και ξανά, να είναι αυτοματοποιημένη για να επισημαίνεται ακόμα και αν αντιγράφονται νέα κελιά στη στήλη όπου έχει προγραμματιστεί η μακροεντολή;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό είναι πραγματικά υπέροχο, αλλά ο χρωματισμός σταμάτησε μετά τη σειρά 66 (9 χρώματα). Πώς μπορώ να επεκταθεί αυτό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Anri,
Ο παραπάνω κώδικας λειτουργεί καλά στο φύλλο εργασίας μου, τον δοκιμάζω σε 300 εκατοντάδες σειρές.
Δοκιμάστε το ξανά. Ή μπορείτε να στείλετε το αρχείο του βιβλίου εργασίας σας στον λογαριασμό email μου.
Ο λογαριασμός email μου είναι: skyyang@extendoffice.com
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
υπάρχει κάποιο λάθος σχετικά με τη ρύθμιση χρωματικού ευρετηρίου, το xCindex θα είναι μεγαλύτερο από 56 εάν υπάρχουν 56 δεδομένα σειρών στο φύλλο σας, το σύστημα θα αγνοήσει την πρόταση:
Αν xCellPre.Interior.ColorIndex = xlNone Τότε xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
Διορθώνω το πρόγραμμα όπως παρακάτω: \
αν Σφάλμα.αριθμός=457 τότε
if xCellPre.Text<>xCell.Text Τότε
xCindex=xCindex+1
τέλος εαν
σειρά.....
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.
Το φύλλο excel μου έχει 11000 σειρές δεδομένων.
πώς μπορώ να το επεκτείνω για να επισημάνω όλα τα διπλότυπα σε αυτήν τη μεγάλη στήλη.

σταμάτησε στη σειρά 77.

Ευχαριστώ,

AK
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό είναι πραγματικά υπέροχο, αλλά ο χρωματισμός σταμάτησε μετά τη σειρά 76 (5 χρώματα). Πώς μπορώ να επεκταθώ και αυτό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Το υπολογιστικό φύλλο μου επίσης σταμάτησε να χρωματίζεται στις 178 και έχω πάνω από 400 γραμμές. Πώς το διορθώνεις αυτό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Carol,
Θα μπορούσατε να στείλετε το βιβλίο εργασίας σας στη διεύθυνση email μου, ίσως σας βοηθήσω να βρείτε το πρόβλημα.
Η διεύθυνση email μου είναι :skyyang@extendoffice.com
Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Τοποθετήστε Περισσότερα

Ακολουθησε μας

Πνευματικά δικαιώματα © 2009 - www.extendoffice.com. | Ολα τα δικαιώματα διατηρούνται. Τροφοδοτείται από ExtendOffice. | Sitemap
Το Microsoft και το λογότυπο του Office είναι εμπορικά σήματα ή σήματα κατατεθέντα της Microsoft Corporation στις Ηνωμένες Πολιτείες ή / και σε άλλες χώρες.
Προστατεύεται από το Sectigo SSL