Colorier (mettre en gras) les chiffres qui se matchent

[Ninter]

Bonjour le forum,

Je galère sur une macro et j'aimerais l'aide du forum pour faire cette macro.
En effet j'ai sur une feuille excel des numéros de series dans une colonne ainsi que les montants 5généralement débit et crédit). J'aimerais que la macro arrivent pour un numéro de serie donné a mettre en gras chaque montant ainsii que son opposé. Et dans le cas ou il ne trouve pas le montant et son opposé alors il ne fait rien bien sur.
Idéalement si la macro pouvait copier sur une autre feuille les valeurs qui mqtchent cela serait parfait.
Ci-joint un fichier qui je l'espère permettra de bien comprendre mon problème et erci beaucoup a ceux qui s'y pencheront.

Merci

 

[mapomme]

Re : Colorier (mettre en gras) les chiffres qui se matchent

(re) Bonjour à tous,

Ma formule MFC de mon précédent message était erronée (ça me turlupinait depuis que j'avais publié la première version, je sentais bien que quelque chose clochait)

Toujours le même principe: un essai basé sur une formule de MFC. La macro crée une MFC sur la zone de la Feuil1, filtre sur la couleur et recopie la zone filtrée sur Feuil2.

Il faut utiliser la formule suivante:

=ET($B2<>"";NB.SI.ENS($A$2:$A2;$A2;$B$2:$B2;$B2)<=MIN(NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;$B2);NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;-$B2)))

(R41 est remplacé au sein de la macro par le numéro de la dernière ligne de donnée de Feuil1)
Sans la recopie sur Feuil2, le VBA serait inutile et la formule de la MFC suffirait sur la zone A2:B41.


Explication de la formule:
Elle est basée sur le fait que si un couple (A,B) doit être marqué, c'est parce que son couple opposé (A,-B) existe aussi. Pour (A,B) donné, on ne pourra marquer qu'un nombre de couple (A,B) dont les opposés (A,-B) existent aussi. Donc pour un couple (A,B), c'est le minimum entre le nombre de couples (A,B) et de couples (A,-B) qui déterminera le nombre de couples qu'on peut marquer au sein de toute la plage. Soit N ce nombre minimum.

Ensuite en parcourant la zone, si on tombe sur un couple (A,B) ou (A,-B), la ligne sera à marquer si le rang d'apparition du couple est inférieur ou égal au minimum N. Les couples de rang supérieur à N ne sont pas à marquer puisqu'ils n'ont plus d'opposés.

Cette formule pour chaque couple (A,B) recherche le nombre minimum entre le nombre d'apparitions des couples (A,B) et le nombre d'apparitions des couples opposés (A,-B) et cela sur l'ensemble de la zone A2:B41.
Pour le couple de la ligne 2, cela donne:

MIN(NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;$B2);NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;-$B2))

Ensuite pour chaque ligne de couple (A,B) ou (A,-B), si l'apparition de ce couple à compter de la ligne 2 est inférieur ou égal au MIN trouvé ci-dessus, alors la ligne doit être marquée. Ce qui donne:

NB.SI.ENS($A$2:$A2;$A2;$B$2:$B2;$B2)<=MIN(NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;$B2);NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;-$B2))

On ne marque pas les lignes sans valeur dans la colonne B, d'où la formule finale:

=ET($B2<>"";NB.SI.ENS($A$2:$A2;$A2;$B$2:$B2;$B2)<=MIN(NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;$B2);NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;-$B2)))

Le code (à part la définition de la variable formule bien sûr) reste identique au code de mon précédent post:

Sub MFC_Recopie()
Dim FormuleMFC$, Ncol&, Plage As Range
  Application.ScreenUpdating = False
  FormuleMFC = "=ET($B2<>"""";NB.SI.ENS($A$2:$A2;$A2;$B$2:$B2;$B2)<=MIN(NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;$B2);NB.SI.ENS($A$2:$A$41;$A2;$B$2:$B$41;-$B2)))"
  With Worksheets("Feuil1")
    Ncol = .Cells(.Rows.Count, "a").End(xlUp).Row
    FormuleMFC = Replace(FormuleMFC, "R41", "R" & Ncol)
    If .AutoFilterMode Then .Cells.AutoFilter
    Set Plage = .Range(.Cells(2, "a"), .Cells(Ncol, "b"))
    Plage.FormatConditions.Delete
    Plage.FormatConditions.Add Type:=xlExpression, Formula1:=FormuleMFC
    Plage.FormatConditions(1).Font.Bold = True
    Plage.FormatConditions(1).Interior.Color = RGB(225, 250, 120)
    Set Plage = Plage.Offset(-1).Resize(Plage.Rows.Count + 1)
    Plage.AutoFilter Field:=1, Criteria1:=RGB(225, 250, 120), Operator:=xlFilterCellColor
    Worksheets("Feuil2").Range("a:b").Clear
    Plage.SpecialCells(xlCellTypeVisible).Copy Worksheets("Feuil2").Range("a1")
    .Cells.AutoFilter
  End With
  Application.ScreenUpdating = True
End Sub

nota: correction -> suite au changement de formule, il faut remplacer $41 par "$" & Ncol. ce qui donne la version v3 ICI.

 

[Ninter]

Re : Colorier (mettre en gras) les chiffres qui se matchent

bonjour le forum,
Merci beaucoup pour vos solutions, que je prends le temps de tester une a une.
PierreJean merci beaucoup pour tes interventions, pareil 0 Robert et Mapomme.
Par contre mapomme quand je lance ta macro, j4ai un message de procédure non existante, est ce normale?
Merci beaucoup

 

[mapomme]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Bonjour Ninter,

[...] mapomme quand je lance ta macro, j'ai un message de procédure non existante, est ce normale?
Merci beaucoup [...]

Ce n'est pas normal, j'ai refait un fichier v2b à tester...

Question 1: Sinon, quand on lance la macro directement depuis l'environnement VBA, cela marche t il ?

Question 2 : D'autres auraient ils le même PB que toi avec la version v2 ?

Décidément quand je fais vite, je fais bêtises sur bêtises. La version v3 qui devrait fonctionner correctement! Je remplaçais R41 au lieu de remplacer $41 suite au changement de formule.

 

[pierrejean]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Re

Ma derniere version

Sub test()
coul = 4
For n = 2 To Range("A" & Rows.Count).End(xlUp).Row
 For m = n + 1 To Range("B" & Rows.Count).End(xlUp).Row
  If Range("A" & n) = Range("A" & m) And Range("B" & m) = -Range("B" & n) Then
   If Range("B" & n).Interior.ColorIndex = xlNone And Range("B" & m).Interior.ColorIndex = xlNone Then
     Range("B" & n).Font.ThemeColor = xlThemeColorDark1
     Range("B" & m).Font.ThemeColor = xlThemeColorDark1
     Range("B" & n).Interior.ColorIndex = coul
     Range("B" & m).Interior.ColorIndex = coul
     Range("A" & n).Font.ThemeColor = xlThemeColorDark1
     Range("A" & m).Font.ThemeColor = xlThemeColorDark1
     Range("A" & n).Interior.ColorIndex = coul
     Range("A" & m).Interior.ColorIndex = coul
     coul = coul + 1
    End If
   End If
 Next
Next
End Sub

@ mapomme

Chez moi ta v3 a fonctionné 1 fois seulement !!

 

[Ninter]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Bonjour Mapomme
Moi aussi j'ai eu un probleme avec la nouvelle version 3.
PierreJean, quand je met la nouvelle macro, que je lance excel me dit variable non definie sur coul?
En tout cas merci pour toutes les solutions que je prends.
Idéalement PierreJean avec ta macro si on pouvait avoir sur un autre onglet le recopiage de toutes les données (valeurs) trouvées, ce serait parfait car avec cette macro je parcours souvent 1000 lignes pour voir tous les nombres coloriés.
Merci et ci-joint mon fichier avec lequel j'ai variable non défini.

Merci

 

[pierrejean]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Re

Vois si cela te convient (tester sur Feuil2)
NB : dans tes résultats tu colores 2 fois aa2 -4

PS: pour 1 fois j'ai mis en option explicit et déclaré les variables

 

[Ninter]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Merci PierreJean
C'est une erreur de ma part d'avoir colorié deux fois.
La j'ai lancé sur la feuille ca marche parfaitement.
Je vais le tester sur mon projet et je te dirai.
merci sincèrement pour toutes tes propositions.
Ainsi qu'au forum pour les solutions données

 

[mapomme]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Bonsoir Ninter, pierrejean,

Je ne comprends pas pourquoi ça marche chez moi et pas chez vous. Pouvez-vous m'en dire un peu plus sur l'endroit du bug ?

Merci.

 

[pierrejean]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Re

Version avec une petite 'coquetterie' : en fonction de la couleur de fond la couleur du texte est soit noire soit blanche pour une meilleure lisibilité

@ mapomme

Chez moi le bug consiste tout simplement en ce que les couleurs ne viennent plus (mais elles sont venues une fois !!!!)
Et j'ai repris le fichier d'origine
NB: pour des raisons bizarres je suis sous XL 2007

 

[zinedine1]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Merci beaucoup, cela fonctionne!

 

[laurent950]

Re : Colorier (mettre en gras) les chiffres qui se matchent

Bonsoir,

Sub test2()

Dim TabOrg() As Variant
Dim Tabcoul As Range

TabOrg = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 2))
ReDim Preserve TabOrg(1 To UBound(TabOrg, 1), 1 To 5)

Set Tabcoul = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 2))

For i = 1 To UBound(TabOrg, 1)
    For j = i + 1 To UBound(TabOrg, 1)
        If TabOrg(i, 1) = TabOrg(j, 1) Then
            TabOrg(j, 3) = "x"
        End If
    Next j
Next i

'CLng(xx) = Right(TabOrg(K, 2), Len(TabOrg(K, 2)) - 1)

For i = 1 To UBound(TabOrg, 1)
    If TabOrg(i, 3) = "" Then
        For j = i To UBound(TabOrg, 1)
            For k = i To UBound(TabOrg, 1)
                If TabOrg(i, 1) = TabOrg(j, 1) And TabOrg(i, 1) = TabOrg(k, 1) Then
                    If TabOrg(k, 2) Like "-" & "*" Then
                        If TabOrg(j, 2) = CLng(Right(TabOrg(k, 2), Len(TabOrg(k, 2)) - 1)) Then
                            ' reperage
                            TabOrg(j, 4) = "V"
                            TabOrg(k, 4) = "V"
                            ' couleur
                            Tabcoul(j, 2).Interior.ColorIndex = k
                            Tabcoul(k, 2).Interior.ColorIndex = k
                        End If
                    End If
                End If
            Next k
        Next j
    End If
Next i

'Cells(2, 1).Resize(UBound(TabOrg, 1), UBound(TabOrg, 2)) = TabOrg

End Sub

laurent