Colorier (mettre en gras) les chiffres qui se matchent

N

Ninter

XLDnaute Occasionnel
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
 

Pièces jointes

  • Essai.xlsx
    9.7 KB · Affichages: 45
  • Essai.xlsx
    9.7 KB · Affichages: 49
  • Essai.xlsx
    9.7 KB · Affichages: 49
Dernière édition:
Trier par date Trier par votes
pierrejean

pierrejean

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

Bonjour Ninter

A tester:

Code: 
Sub test()
coul = 1
For n = 2 To Range("A" & Rows.Count).End(xlUp).Row
x = -Range("B" & n)
Set c = ActiveSheet.Columns(2).Find(x, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
  c.Interior.ColorIndex = coul
  c.Font.ThemeColor = xlThemeColorDark1
  Range("B" & n).Interior.ColorIndex = coul
  Range("B" & n).Font.ThemeColor = xlThemeColorDark1
  coul = coul + 1
End If
Next
End Sub
 
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re : Colorier (mettre en gras) les chiffres qui se matchent

Bonjour Ninter, bonjour le forum,

Faut être patient Ninter, c'est les vacances...
Essaie comme ça :
Code: 
Sub Macro3()
Dim O1 As Object 'déclare la variable O1 (onglet 1)
Dim O2 As Object 'déclare la variable O2 (onglet 2)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim PLV As Range 'déclare la variable PLV (Plage Visible)
Dim C1 As Range 'déclare la variable C1 (Cellule 1)
Dim C2 As Range 'déclare la variable C2 (Cellule 2)
Dim DEST As Range 'déclare la variable DEST (celulle de DESTination)

Set O1 = Sheets("Feuil1") 'définit l'onglet O1
Set O2 = Sheets("Feuil2") 'définit l'onglet O1
DL = O1.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 1 (=A) de l'onglet O1
Set PL = O1.Range("A2:A" & DL) 'définit la plage PL
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In PL 'boucle sur toutes les cellules CEl de la plage PL
    D(CEL.Value) = "" 'alimente le diciotnnaire D
Next CEL 'prochaine cellule de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP les éléments du dictionnaire D sans doublon
For I = 0 To UBound(TMP) 'boucle 1 sur les éléments du tableau TMP
    O1.Range("A1").AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la colonne 1 (=A) de l'onglet O1 avec TMP(I) comme critère
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'de'finit la plage PLV (cellule visibles (non filtrées) de la plage PL
    For Each C1 In PLV.Offset(0, 1) 'boucle 2 : sur toutes les cellule de la plage PLV
        'boucle 3 : sur toutes les cellule de la plage PLV (moins la première ligne)
        For Each C2 In PLV.Offset(1, 1).Resize(PLV.Rows.Count - 1, PLV.Columns.Count)
            'condition : si la cellule C1 vaut - la cellule C2 et si C1 n'est pas colorée de rouge
            If C1.Value = -C2.Value And C1.Interior.ColorIndex <> 3 Then
                'définit la cellule de destination DEST (A1 si A1 est vide, sinon, première ligne vide de la colonne A de l'onglet O2)
                Set DEST = IIf(O2.Range("A1").Value = "", O2.Range("A1"), O2.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                C1.EntireRow.Copy DEST 'copie la ligne de C1 dans DEST
                C2.EntireRow.Copy DEST.Offset(1, 0) 'copie la ligne de C2 dans la ligne en dessous de DEST
                C1.Interior.ColorIndex = 3: C2.Interior.ColorIndex = 3 'colore C1 et C2 de rouge
                C1.Font.Bold = True: C2.Font.Bold = True 'attribut [Gras] pour C1 et C2
            End If 'fin de la condition
        Next C2 'prochaine cellule de la boucle 3
    Next C1 'prochaine cellule de la boucle 2
    O1.Range("A1").AutoFilter 'supprime le filtre automatique
Next I 'prochaine élément de la boucle 1
End Sub

[Édition]
Damned ! Grillé par la Brute de PierreJean ! Ce n'est pas Bon, quel Truand...
 
Vote positif 0 Vote négatif
N

Ninter

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

Bonjour PierreJean et Robert, le forum,

PierreJean ta macro marche mais j'ai un petit souci avec:
Elle colore de la meme couleur deux nombres opposes meme si ils n'ont pas le meme numero de serie.
Alors que la premiere condition c'est le numero de serie ensuite de colorer les nombres opposes.
Robert j'ai essaye la macro quand elle est lancee, apres j'ai erreur 400.
J'espere que je pourrai avoir vos retours.
Merci et j'essaie de trouver la solution...
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

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

Re

Salut Robert

@ Ninter

Cela devrait aller un peu mieux

Code: 
Sub test()
coul = 3
For n = 2 To Range("A" & Rows.Count).End(xlUp).Row
x = -Range("B" & n)
Set c = ActiveSheet.Columns(2).Find(x, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
 If Range("A" & c.Row) = Range("A" & n) Then
  c.Interior.ColorIndex = coul
  c.Font.ThemeColor = xlThemeColorDark1
  Range("B" & n).Interior.ColorIndex = coul
  Range("B" & n).Font.ThemeColor = xlThemeColorDark1
  coul = coul + 1
 End If
End If
Next
End Sub
 
Vote positif 0 Vote négatif
N

Ninter

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

Merci PierreJean pour la modif
Mais je teste sur un echantillon simple et j'ai un petit probleme caril ne colore pas tous mes nombres qui sont censes matches.
Jai pris l'exemple ci-dessous:
Numero de serie (aa dans la colonne A) puis les nombres suivants( -1730; -3,15; -3,50; 1730; 3,5)
La macro me colore les nombres 1730 et -1730 seulement sans me colorier le -3,50 et 3,50.
Merci pour l'aide
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

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

Re

Ok

Ceci devrait aller encore un peu mieux

Code: 
Sub test()
coul = 4
For n = 2 To Range("A" & Rows.Count).End(xlUp).Row
 For m = 2 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 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
 
Vote positif 0 Vote négatif
H

Habitude

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

Bonjour

Avec validation, à l'aide d'un vecteur booléen, pour ne pas prendre un compte une valeur déjà balancée.

Ex.
AA1 5
AA1 -5
AA1 5

Le troisième 5 ne doit pas être considéré
 

Pièces jointes

  • ColorDebitCredit.xlsm
    21 KB · Affichages: 42
Vote positif 0 Vote négatif
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Re : Colorier (mettre en gras) les chiffres qui se matchent

Bonsoir le fil, bonsoir le forum,

Désolé Ninter j'avais pourtant testé avant d'envoyer. Le code modifié :
Code: 
Sub Macro3()
Dim O1 As Object 'déclare la variable O1 (onglet 1)
Dim O2 As Object 'déclare la variable O2 (onglet 2)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim PLV As Range 'déclare la variable PLV (Plage Visible)
Dim C1 As Range 'déclare la variable C1 (Cellule 1)
Dim C2 As Range 'déclare la variable C2 (Cellule 2)
Dim DEST As Range 'déclare la variable DEST (celulle de DESTination)

Set O1 = Sheets("Feuil1") 'définit l'onglet O1
Set O2 = Sheets("Feuil2") 'définit l'onglet O1
DL = O1.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 1 (=A) de l'onglet O1
Set PL = O1.Range("A2:A" & DL) 'définit la plage PL
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In PL 'boucle sur toutes les cellules CEl de la plage PL
    D(CEL.Value) = "" 'alimente le diciotnnaire D
Next CEL 'prochaine cellule de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP les éléments du dictionnaire D sans doublon
For I = 0 To UBound(TMP) 'boucle 1 sur les éléments du tableau TMP
    O1.Range("A1").AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la colonne 1 (=A) de l'onglet O1 avec TMP(I) comme critère
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'de'finit la plage PLV (cellule visibles (non filtrées) de la plage PL
    For Each C1 In PLV.Offset(0, 1) 'boucle 2 : sur toutes les cellule de la plage PLV
        'boucle 3 : sur toutes les cellule de la plage PLV (moins la première ligne)
        For Each C2 In PLV.Offset(0, 1)
            'condition : si la cellule C1 vaut - la cellule C2 et si C1 n'est pas colorée de rouge
            If C1.Value = -C2.Value And C1.Interior.ColorIndex <> 3 And C2.Interior.ColorIndex <> 3 Then
                'définit la cellule de destination DEST (A1 si A1 est vide, sinon, première ligne vide de la colonne A de l'onglet O2)
                Set DEST = IIf(O2.Range("A1").Value = "", O2.Range("A1"), O2.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
                C1.EntireRow.Copy DEST 'copie la ligne de C1 dans DEST
                C2.EntireRow.Copy DEST.Offset(1, 0) 'copie la ligne de C2 dans la ligne en dessous de DEST
                C1.Interior.ColorIndex = 3: C2.Interior.ColorIndex = 3 'colore C1 et C2 de rouge
                C1.Font.Bold = True: C2.Font.Bold = True 'attribut [Gras] pour C1 et C2
            End If 'fin de la condition
        Next C2 'prochaine cellule de la boucle 3
    Next C1 'prochaine cellule de la boucle 2
    O1.Range("A1").AutoFilter 'supprime le filtre automatique
Next I 'prochaine élément de la boucle 1
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

N
  • Question
XL 2019 Mettre en gras éléments du graphique avec macro
Réponses
4
Affichages
360
Nasseuz
N
T
  • Question
XL 2010 Supprimer les lignes en doubles (multi critères)
2
Réponses
18
Affichages
1 K
oguruma
oguruma
P
  • Question
XL 2016 Aide pour transformer une idée en macro Excel
2
Réponses
19
Affichages
867
TooFatBoy
TooFatBoy
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
290
vgendron
vgendron
J
  • Question
XL 2016 Parcourir les chaînes de caractères et mettre en gras si elles contiennent des chiffres
Réponses
5
Affichages
797
JN1
J
Y
  • Question
XL 2019 Besoin d'aide pour une Macro pouvant doubler des lignes et remplir des colonnes
Réponses
7
Affichages
579
chris
chris
N
  • Résolu(e)
XL 2016 Utilisation de la fonction "si" plusieurs critères
Réponses
9
Affichages
763
AtTheOne
AtTheOne
N
  • Question
XL 2016 Automatisation Rapprochement bancaire
2
Réponses
21
Affichages
4 K
Novice excel vba
N
H
  • Résolu(e)
Microsoft 365 VBA texte en gras avec formule
2
Réponses
22
Affichages
3 K
soan
S
B
  • Question
Autres Mise en gras une partie de chaine dans textbox ou label
Réponses
6
Affichages
759
Simply
Simply

Membres actuellement en ligne

4 membres et 67 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 329
Messages
2 087 334
Membres
103 519
dernier inscrit
Thomas_grc11