Comparer le contenu texte de deux cellules et mettre en rouge les différences

[Imperium]

Bonjour à tous !

Ma problématique tient dans le titre

En fait, j''ai une colonne A avec des valeurs textes (des paragraphes très long), et en colonne B, je copie/colle les mêmes valeurs textes, venues d'une autre source. Théoriquement, ces valeurs sont les mêmes donc pas de problème.
Dans les faits, il y a souvent des écarts (éléments manquant, faute d'orthographe, manque une majuscule...)

Ce que je voudrais, c'est que je copie en colonne B les éléments externes, puis, avec un bouton, executer une comparaison qui sous ligne + couleur rouge les éléments différents. Si c'est carrément un élément manquant, alors tout ce que vient derrière cet éléments manquant s'illumine en rouge.

Exemple :

Colonne A
Un avion vole

Colonne B
Un Avion volent


(Je n'ai pas trouvé comment mettre en rouge sur le fofo ^^)

Idéalement, le fichier detecte les différence entre gras et italique également.

Un immense merci !

 

[david84]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Bonjour,
le plus simple est de fournir un petit fichier exemple comportant les différents cas de figure que l'on peut trouver.

Dans les faits, il y a souvent des écarts (éléments manquant, faute d'orthographe, manque une majuscule...)

par élément manquant tu sous-entends le "nt" de "volent" qui peut manquer ou peut-il y avoir des mots entiers qui manquent (un avion vole/un gros avion vole). Normalement non puisque c'est un copier coller mais ceci-dit si c'est un copier-coller je m'explique mal le "nt" qui apparaît dans un cas et pas dans l'autre.
Je pense que le fichier exemple nous permettrait d'y voir plus claire.
A+

 

[Imperium]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Merci pour ton aide, je joins le fichier.
En fait, j'ai simplifié ma demande car au plus j'y pense au plus je me dis que ça va être très complexe. Pour faire plus simple, il faudrait qu'à l'exécution de la macro, le texte se recopie en colonne C et qu'à la première différence (espace, format, caractère en + ou manquant)entre le texte en A ou en B, le reste de la cellule se surligne + couleur rouge jusqu'à la fin de la cellule, comme ça l'utilisateur voit ou se trouve la différence, la corrige en colonne B et relance la macro.

Le fichier exemple sera plus clair je pense.
En fait, pour expliquer, j'envois des listes à un opérateur qui doit les recopier à la main sur une autre source, mais il fait très souvent des erreurs (oubli, format...), du coup, je prends ce qu'il a recopier et le remet dans excel pour le comparer avec ce que je lui ai envoyé. IL peut s'agir de listes d'ingrédients très longues, d'ou ma demande.

 

[david84]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Re

En fait, pour expliquer, j'envois des listes à un opérateur qui doit les recopier à la main sur une autre source

peut-être que c'est à ce niveau-là qu'il faudrait automatiser une procédure plutôt que de monter une usine à gaz...
pas le temps aujourd'hui de regarder cela mais j'y jetterai un coup d’œil dès que je peux si personne ne t'est venu en aide entre temps.
A+
PS : quel intérêt de relever les différences de police (italique ou pas par exemple) ?

 

[Imperium]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Merci David c'est très sympa.
L'intérêt c'est tout simplement d'identifier uneune différence, même de mise en forme, qui n'aurait pas lieu d'être.

J'ai trouver un code sur le net qui fait à peu près ce que je veux, mais sa lenteur d'exécution le rend inutilisable au dela d'un texte de 300 caractères.

Sub correction()
     Dim maFeuille As Worksheet
     Dim nbLigneVideConsecutive As Integer
     Dim LigneEnCours As Long 'integer ne suffit pas (capacité + 32 000 / - 32 000, il y a 65 000 lignes dans la feuille)
     Dim CarEnCours As Integer
     Dim TxtTst As String, TxtRef As String, TxtAlert As String
     Dim maCell As Range
     
     Set maFeuille = ActiveWorkbook.ActiveSheet
     Set maCell = maFeuille.Cells(6, 3)
     nbLigneVideConsecutive = 0
     LigneEnCours = 3
     
     Do While nbLigneVideConsecutive < 5  ' paramétrable pour déclencher la sortie
         If maFeuille.Cells(LigneEnCours, 2) = maFeuille.Cells(LigneEnCours, 3) Then
         'les deux cellules sont identiques mais sont elles vides ?
             If maFeuille.Cells(LigneEnCours, 2) = "" Then
             'elles sont vides : j'incrémente mon compteur qui me sert à sortir
                 nbLigneVideConsecutive = nbLigneVideConsecutive + 1
             End If
         Else ' il y a une différence, analysons la.
             Set maCell = maFeuille.Cells(LigneEnCours, 4)
             TxtTst = maFeuille.Cells(LigneEnCours, 2)
             TxtRef = maFeuille.Cells(LigneEnCours, 3)
             maCell = TxtRef
             For CarEnCours = 1 To Len(TxtTst)
                 If Mid(TxtTst, CarEnCours, 1) = Mid(TxtRef, CarEnCours, 1) Then
                 ' si le caractère est identique je lui affecte la couleur noir RGB(0,0,0,)
                     With maCell.Characters(Start:=CarEnCours, Length:=1).Font
                         .Name = "Verdana"
                         .FontStyle = "Normal"
                         .Size = 10
                         .Strikethrough = False
                         .Superscript = False
                         .Subscript = False
                         .OutlineFont = False
                         .Shadow = False
                         .Underline = xlUnderlineStyleNone
                         .Color = RGB(0, 0, 0)
                     End With
                 Else 'si le caractère est différent je lui affecte la couleur rouge RGB(255,0,0)
                     With maCell.Characters(Start:=CarEnCours, Length:=1).Font
                         .Name = "Verdana"
                         .FontStyle = "Normal"
                         .Size = 10
                         .Strikethrough = False
                         .Superscript = False
                         .Subscript = False
                         .OutlineFont = False
                         .Shadow = False
                         .Underline = xlUnderlineStyleNone
                         .Color = RGB(255, 0, 0)
                     End With
                 End If
             Next CarEnCours
         End If
         LigneEnCours = LigneEnCours + 1
     Loop
     MsgBox ("Correction terminée")
 End Sub

 

[david84]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Re

tu n'as pas répondu à mon interrogation

peut-être que c'est à ce niveau-là qu'il faudrait automatiser une procédure plutôt que de monter une usine à gaz...

Qu'est ce qui empêcherait de traiter la cause du problème et non sa conséquence ?

Quant au code de ton dernier message je ne l'ai pas testé pas s'il faut être obligé de comparer lettre par lettre c'est sûr que cela est très long (et encore je n'ai pas l'impression que les polices, gras et italiques sont comparés dans ce code). Il vaut mieux comparer les textes 1 et 2 mot par mot et alerter au 1er mot de la phrase 2 qui ne correspond pas à la phrase 1. Ceci-dit mieux ne vaut pas comparer les polices, gras, italique, etc. parce que sinon cela va prendre un temps fou (et en plus je n'y vois aucun intérêt).
A+

 

[david84]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Bonjour,
en attendant que tu répondes à mes questions, ci-joint une possibilité à améliorer par la suite :

Sub Comparer_texte()
Dim Pl_Tinit As Range, Pl_Tcomp As Range, PlTfin As Range
Dim T_Tinit, T_Tcomp
Dim DerLig As Long, Diff  As Long
Dim i As Long, j As Long

Columns(3).ClearContents
DerLig = Range("A" & Rows.Count).End(xlUp).Row
Set Pl_Tinit = Range("A3:A" & DerLig)
Set Pl_Tcomp = Range("B3:B" & DerLig)
Range("C3:C" & DerLig).Value = Range("B3:B" & DerLig).Value
Set Pl_Tfin = Range("C3:C" & DerLig)

For i = 1 To DerLig
  T_Tinit = Split(Pl_Tinit(i, 1))
  T_Tcomp = Split(Pl_Tcomp(i, 1))
  For j = LBound(T_Tinit) To UBound(T_Tinit)
    If T_Tinit(j) <> T_Tcomp(j) Then
      Diff = InStr(1, Pl_Tcomp(i, 1), T_Tcomp(j))
      Pl_Tfin(i, 1).Characters(Diff, Len(T_Tcomp(j))).Font.ColorIndex = 3
      Pl_Tfin(i, 1).Characters(Diff, Len(T_Tcomp(j))).Font.Underline = xlUnderlineStyleSingle
      Diff = 0
      Exit For
    End If
  Next j
Next i
End Sub

A+

 

[Imperium]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Merci David je teste ça.

En fait cela répond à une problématique purement fonctionnelle. On donne une liste d'ingrédients à des usines, qui nous les renvoit sous un format différent (car incluse dans une présentation plus globale), et donc, parfois, dans ce format différent et pour une liste de parfois 2000 caractères, on se rend compte qu'un ingrédient a magiquement disparu (on est d'accord, s'ils s'étaient contentés de faire un copier/coller de la liste initiale, cela ne devrait pas arriver mais dans les faits, ce n'est pas le cas, beaucoup sont recopiées à la main à cause de contrainte logicielles), d'où la volonté pour nous de vérifier la liste finale avec notre liste initiale, via une macro.

Voilà, je crois que j'ai tout dit Merci en tout cas !

 

[klin89]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Bonsoir à tous,
Bonjour Imperium,
Salut david84,

Pas très clair en effet
Tu parles d'afficher les différences entre 2 cellules.
Une autre façon de procéder, résultat en colonne C

Sub essai()
Dim a, i As Long, j As Long, e
    With Range("a3").CurrentRegion.Resize(, 3)
        .Columns(3).ClearContents
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                For j = 1 To 2
                    For Each e In Split(a(i, j), " ")
                        .Item(Trim$(e)) = Empty
                    Next
                Next
                a(i, 3) = Join$(.keys, " ")
                .RemoveAll
            Next
        End With
        .Value = a
    End With
End Sub

Klin89

 

[onha]

Re : Comparer le contenu texte de deux cellules et mettre en rouge les différences

Bonsoir à tous,
Bonjour Imperium,
Salut david84,

Pas très clair en effet
Tu parles d'afficher les différences entre 2 cellules.
Une autre façon de procéder, résultat en colonne C

Sub essai()
Dim a, i As Long, j As Long, e
    With Range("a3").CurrentRegion.Resize(, 3)
        .Columns(3).ClearContents
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                For j = 1 To 2
                    For Each e In Split(a(i, j), " ")
                        .Item(Trim$(e)) = Empty
                    Next
                Next
                a(i, 3) = Join$(.keys, " ")
                .RemoveAll
            Next
        End With
        .Value = a
    End With
End Sub

Klin89

bonjour klin89
je cherche le moyen en utilisant ta macro de faire apparaître uniquement dans la colonne C les valeurs qui ne sont pas égales. Est ce que tu aurais une idée ?
ta macro affiche la colonne A + les valeurs en écart
d'avance merci