Autres Colorer doublons (Spécial)

kaki31

XLDnaute Occasionnel
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.
:)
 

Pièces jointes

  • TestKaki.xlsx
    10 KB · Affichages: 10

Fred0o

XLDnaute Barbatruc
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 :
1617088251119.png
 

job75

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • TestKaki(1).xlsm
    20.8 KB · Affichages: 4
Dernière édition:

job75

XLDnaute Barbatruc
Avec un tableau des repères c'est un peu plus rapide, fichier (2) :
VB:
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
 

Pièces jointes

  • TestKaki(2).xlsm
    21.1 KB · Affichages: 8
Dernière édition:

Discussions similaires

Réponses
2
Affichages
284
Réponses
10
Affichages
404

Statistiques des forums

Discussions
315 127
Messages
2 116 538
Membres
112 773
dernier inscrit
claire3651