Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 doublons

finarobert

XLDnaute Nouveau
Supporter XLD
bonsoir
je possede un tableau excel qui comporte des caractères dans chaque cellule (du genre
>|Q8WZ42.4|TITIN_HUMAN.AltName: Full=Rhabdomyosarcoma antigen MU-RMS-40.14)
.Le nombre de lignes et de colonnes est variable d'un fichier à l'autre. J'aimerai repérer les doublons (ou plus) dans ce tableau et colorer les cellules correspondantes. Au mieux une couleur par doublon sinon une couleur globale. En langage VBA. Pouvez vous m'aider?
merci
 

crocrocro

XLDnaute Occasionnel
Bonsoir,
voici une macro qui devrait répondre à votre besoin en l'adaptant :
- La plage correspond à la sélection courante => à remplacer par votre tableau
- couleur de fond rouge pour les doublons
- j'ai laissé en commentaires des lignes d'instructions qui pourraient vous être utile.


VB:
Sub MFC_Creer_Doublons()
' Créé une MFC de type "Valeurs en Double" pour une Plage
Dim MaPlage As Range
Dim I_MFC As Integer
    Set MaPlage = Selection
    
    ' Ajout des barres de données
    'MaPlage.FormatConditions.Delete
    MaPlage.FormatConditions.AddUniqueValues
    I_MFC = MaPlage.FormatConditions.Count

    'Associe la couleur Rouge à la règle précédente
    'MaPlage.FormatConditions(I_MFC).DupeUnique = xlUnique 'pour les valeurs uniques
    MaPlage.FormatConditions(I_MFC).DupeUnique = xlDuplicate 'pour les doublons
    MaPlage.FormatConditions(I_MFC).Interior.Color = RGB(255, 0, 0)
End Sub
 

finarobert

XLDnaute Nouveau
Supporter XLD
dommage, cela ne fonctionne pas; Cela a mis en rouge certaines cases où il y avait --- et c'est tout
 

finarobert

XLDnaute Nouveau
Supporter XLD
PAREIL, ne fonctionne pas/ Me met en rouge que les cellules marquées ---
 

crocrocro

XLDnaute Occasionnel
Heu !!! je vois mon code mais pas votre fichier...
Une remarque, comme je l'ai dit dans ma 1ère réponse, mon code est associé à la sélection courante et doit être remplacé par votre tableau.
Code:
    Set MaPlage = Selection
Soit vous sélectionner votre tableau soit vous remplacez "Selection" par le range correspondant à votre tableau
 

crocrocro

XLDnaute Occasionnel
Bonjour,
j'ai fait quelques tests dont voici les conclusions :
- La fonction de Mise en forme Conditionnelle "doublons" ne fonctionne que pour des chaines de caractères d'au maximum 255 caractères
- dès lors que la cellule commence par un caractères spécial (comme >), le test ne fonctionne que si le contenu est précédé d'une double apostrophe (le format de cellule "Texte" ne fonctionne pas).
Et c'est une "anomalie" Excel (on obtient le même résultat en passant par "Mise en Forme Conditionnelle" "Gérer les valeurs en Double". Je ne sais pas si l'anomalie a été signalée par Microsoft.
Il faut donc en passer par un code VBA autre (voir fichier en pj)
macro activé par le bouton doublons
VB:
Sub Macro_Doublon()
'
' On met " couleur de fond ROUGE" les cellules en double du tableau
'

' On remet préalablement "sans couleur de fond" les cellules du tableau    Macro_Réinit_Doublon
    Macro_Réinit_Doublon
    
    With ActiveSheet
        For Each cell In .Range("TABLEAU")
            If Not (IsEmpty(cell)) Then
            ' on ne traite que les cellules non vides
                For Each cell2 In .Range("TABLEAU")
                    If (cell2.Value = cell.Value) And (cell.Address <> cell2.Address) Then 'pour seulement les suivantes
                        With cell.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 255
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                        With cell2.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 255
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                    End If
                Next
            End If
        Next

    End With

End Sub
Sub Macro_Réinit_Doublon()
'
' On remet "sans couleur de fond" les cellules du tableau
'
    With ActiveSheet
        For Each cell In .Range("TABLEAU")
            With cell.Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        Next
    End With

End Sub
 

Pièces jointes

  • Test Doublons crocrocro.xlsm
    20.9 KB · Affichages: 5
Dernière édition:

crocrocro

XLDnaute Occasionnel
Ici avec une couleur de fond en nuances de rouge pour chaque groupe de doublons
VB:
Sub Macro_Doublon()
' On met " couleur de fond ROUGE" les cellules en double du tableau
Dim NbDoublon As Integer
Dim Doublon As Boolean
Dim CouleurR As Integer
Dim CouleurV As Integer
Dim CouleurB As Integer
Dim CouleurInc As Integer
' On remet préalablement "sans couleur de fond" les cellules du tableau    Macro_Réinit_Doublon
    Macro_Réinit_Doublon
   
    With ActiveSheet
        NbDoublon = 0
        For Each cell In .Range("TABLEAU")
            Doublon = False
            If Not (IsEmpty(cell)) Then
            ' on ne traite que les cellules non vides
                For Each cell2 In .Range("TABLEAU")
                    If (cell2.Value = cell.Value) And (cell.Address <> cell2.Address) And _
                        (cell.Row <= cell2.Row) And (cell.Column <= cell2.Column) Then 'pour seulement les suivantes
                        ' apparemment les cellules sont balayées par ligne  colonne ( A2,B2 ... A3,B3 ...)
                        If Not Doublon Then
                            'Nuance de rouge pour chaque groupe de doublon
                            Doublon = True
                            CouleurInc = Application.Min(255, NbDoublon * 20)
                            CouleurR = 255 - CouleurInc
                            CouleurV = CouleurInc
                            CouleurB = CouleurInc
                            NbDoublon = NbDoublon + 1
                       End If
                        With cell.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = RGB(CouleurR, CouleurV, CouleurB)
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                        With cell2.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = RGB(CouleurR, CouleurV, CouleurB)
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                    End If
                Next
            End If
        Next

    End With

End Sub
 

finarobert

XLDnaute Nouveau
Supporter XLD
merci! votre exemple marche bien mais moi j'ai une incompatibilité de type 13 à la ligne :

If (cell2.Value = cell.Value) And (cell.Address <> cell2.Address) And _
(cell.Row <= cell2.Row) And (cell.Column <= cell2.Column) Then 'pour seulement les suivantes
zut! j'y crois!
 

finarobert

XLDnaute Nouveau
Supporter XLD
EN REPARTANT à 0 cela marche mais sur mon tableau a oublié 8 doublons (17 ont été trouvés)
 

finarobert

XLDnaute Nouveau
Supporter XLD
je remets un fichier complet avec le VBA de crocrocro. J'ai sélectionné la zone A2:Z100. quand je lance la macro, elle bug comme indiqué ci dessus. Elle a marché une fois mais m'a perdu 8 doublons (dont A43 - O39 par exemple. Je cale
 

Pièces jointes

  • 1-Resultats raccourci.xlsm
    43.2 KB · Affichages: 2

crocrocro

XLDnaute Occasionnel
Votre fichier a des liens externes vers d'autres fichiers -> j'ai rompu les liens
J'ai lancé la macro depuis votre fichier :
L'erreur est due à la cellule T3 qui contient

Je l'ai vidé et continué le traitement _> tout est OK
A voir de votre côté pourquoi cette erreur en T13.
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…