Autres Colorer doublons (Spécial)

[kaki31]

Bonjour,
J'ai un petit souci pour colorer des doublons (valeur positive et négative) sur la colonne O, comme indiqué sur la colonne P.
Tout est dans l'exemple en pièce jointe.
Merci.
🙂

 

[job75]

Bonsoir kaki31,

Puisque vous plaisantez je fais de même :

- sélectionner la colonne P, clic droit => Copier

- sélectionner la colonne O, clic droit => Collage spécial-Formats.

A+

 

[kaki31]

Bonsoir job75,
je ne comprend pas votre réponse, dans la colonne P chaque chiffre positif a la même couleur qu’un même chiffre négatif, genre lettrage mais sans référence.
Merci.
🙂

 

[Fred0o]

Bonjour kki31, Job75.

@kaki31 : Je pense que ta plaisanterie vient du fait que ton exemple est tout sauf logique et dans ces conditions, aucune formule ni programme ne peut colorer les soi-disant doublons a ta place.
Voici en image, ce que j'appelle doublon :

 

[job75]

Re, salut Fred0o,

En fait le problème est tout à fait cohérent mais kaki31 nous a entraînés sur une fausse piste en parlant de doublons.

Il s'agit en fait de colorer les paires de nombres de même valeur absolue mais de signes opposés.

Alors voyez le fichier .xlsm joint et cette macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal target As Range)
Dim couleur As Range, lig&, P As Range, rc&, i&, v, j&
Set couleur = Columns("Q").Cells 'colonne à adapter
lig = 2 '1ère ligne de couleur
If FilterMode Then ShowAllData
Set P = Range("O1", Range("O" & Rows.Count).End(xlUp)) 'colonne à adapter
rc = P.Rows.Count
Application.ScreenUpdating = False
P.Interior.ColorIndex = xlNone 'RAZ
For i = 1 To rc
    If IsNumeric(CStr(P(i))) And P(i).Interior.ColorIndex = xlNone Then
        v = -P(i)
        For j = i + 1 To rc
            If P(j) = v Then
                If P(j).Interior.ColorIndex = xlNone Then
                    Union(P(i), P(j)).Interior.Color = couleur(lig).Interior.Color
                    lig = lig + 1
                    If couleur(lig).Interior.ColorIndex = xlNone Then lig = 2 'on reprend les couleurs au début
                    Exit For
                End If
            End If
        Next j
    End If
Next i
End Sub

Elle se déclenche quand on modifie ou valide une cellule quelconque.

Elle n'est pas très rapide car la lecture des couleurs et les colorations prennent du temps.

A+

 

[job75]

Avec un tableau des repères c'est un peu plus rapide, fichier (2) :

Private Sub Worksheet_Change(ByVal target As Range)
Dim couleur As Range, lig&, P As Range, rc&, a(), i&, v, j&
Set couleur = Columns("Q").Cells 'colonne à adapter
lig = 2 '1ère ligne de couleur
If FilterMode Then ShowAllData
Set P = Range("O1", Range("O" & Rows.Count).End(xlUp)) 'colonne à adapter
rc = P.Rows.Count
ReDim a(1 To rc) 'tableau des repères
Application.ScreenUpdating = False
P.Interior.ColorIndex = xlNone 'RAZ
For i = 1 To rc
    If IsNumeric(CStr(P(i))) And IsEmpty(a(i)) Then
        v = -P(i)
        For j = i + 1 To rc
            If P(j) = v Then
                If IsEmpty(a(j)) Then
                    a(j) = 1 'repère
                    Union(P(i), P(j)).Interior.Color = couleur(lig).Interior.Color
                    lig = lig + 1
                    If couleur(lig).Interior.ColorIndex = xlNone Then lig = 2 'on reprend les couleurs au début
                    Exit For
                End If
            End If
        Next j
    End If
Next i
End Sub

 

[kaki31]

Merci job75
🙂