Comparaison entre 2 cellules/column

[Achil]

Bonjour à tous,

Comme d'hab, j'ai besoin de votre aide.

je souhaite comparer entre 2 cellules et mettre en gras/couleur dans une autre cellule et en tenant compte aussi d'une différence si cellule non alignée.

Voir exple ci joint (column Result)

Merci d'avance 😱😱😱

 

[job75]

Re : Comparaison entre 2 cellules/column

Bonjour Achil,

Comparer les textes situés sur une même ligne ne pose pas de problème, voyez le fichier joint et cette macro :

Sub Comparer()
Dim h As Long, cel As Range, i As Integer
'---initialisation---
Application.ScreenUpdating = False
[F2:F65536].ClearContents
[F2:F65536].Font.Bold = False
[F2:F65536].Font.ColorIndex = xlAutomatic
h = [E65536].End(xlUp).Row - 1
If h = 0 Then Exit Sub
'---remplissage de la colonne F---
[F2].Resize(h) = [E2].Resize(h).Value
'---comparaison avec la colonne C---
For Each cel In [F2].Resize(h)
  For i = 1 To Len(cel.Text)
    If Mid(cel.Text, i, 1) <> Mid(cel.Offset(, -3).Text, i, 1) Then
      cel.Characters(i, 1).Font.Bold = True 'gras
      cel.Characters(i, 1).Font.ColorIndex = 3 'rouge
    End If
  Next
Next
End Sub

Par contre comparer des textes situés sur des lignes différentes n'est guère logique : comment savoir quels sont les textes à comparer ???

A+

 

[Achil]

Re : Comparaison entre 2 cellules/column

Merci pour la première solution 😱

mais n'est il pas possible de comparer en recherchant si par exple

Si reference = x , comparer B6 : D6
Si B6 = D6, comparer
Si B6 <> D6, recherche ds la column B et faire la comparaison

malheuresement je suis pas encore pro, mais j'espère que ma demande est un peu claire 😕

thankssss 😱😱

 

[job75]

Re : Comparaison entre 2 cellules/column

Re,

Par contre comparer des textes situés sur des lignes différentes n'est guère logique

On peut toutefois rechercher les textes qui donnent un nombre de différences minimum :

Sub Comparer()
Dim h&, cel As Range, cel1 As Range, Ndif%(), i%
'---initialisation---
Application.ScreenUpdating = False
[F2:F65536].ClearContents
[F2:F65536].Font.Bold = False
[F2:F65536].Font.ColorIndex = xlAutomatic
h = [E65536].End(xlUp).Row - 1
If h = 0 Then Exit Sub
For Each cel In [F2].Resize(h)
  '---recherche du nombre de différences minimum---
  cel = cel.Offset(, -3)
  ReDim Ndif(1 To h)
  For Each cel1 In [E2].Resize(h)
    For i = 1 To Len(cel.Text)
      If Mid(cel.Text, i, 1) <> Mid(cel1.Text, i, 1) Then _
        Ndif(cel1.Row - 1) = Ndif(cel1.Row - 1) + 1
    Next
  Next
  cel = [E1].Offset(Application.Match(Application.Min(Ndif), Ndif, 0))
  '---comparaison avec la colonne C---
  For i = 1 To Len(cel.Text)
    If Mid(cel.Text, i, 1) <> Mid(cel.Offset(, -3).Text, i, 1) Then
      cel.Characters(i, 1).Font.Bold = True 'gras
      cel.Characters(i, 1).Font.ColorIndex = 3 'rouge
    End If
  Next
Next
End Sub

Fichier joint.

Tout ça est un peu tiré par les cheveux non ?

Nota : dans votre fichier du post #1 le résultat en F6 n'est pas correct...

A+

 

[job75]

Re : Comparaison entre 2 cellules/column

Re,

Si pour chaque référence les pays (Client 1/Client 2) se correspondent de manière biunivoque, on peut faire 2 tris préalables :

Sub Comparer()
Dim h As Long, cel As Range, i As Integer
'---initialisation---
Application.ScreenUpdating = False
[F2:F65536].ClearContents
[F2:F65536].Font.Bold = False
[F2:F65536].Font.ColorIndex = xlAutomatic
h = [E65536].End(xlUp).Row - 1
If h = 0 Then Exit Sub
'---tris préalables---
[A:E].Sort [A1], , [B1], Header:=xlYes
[D:D].Insert: [A:A].Copy [D1]
[D:F].Sort [D1], , [E1], Header:=xlYes
[D:D].Delete
'---remplissage de la colonne F---
[F2].Resize(h) = [E2].Resize(h).Value
'---comparaison avec la colonne C---
For Each cel In [F2].Resize(h)
  For i = 1 To Len(cel.Text)
    If Mid(cel.Text, i, 1) <> Mid(cel.Offset(, -3).Text, i, 1) Then
      cel.Characters(i, 1).Font.Bold = True 'gras
      cel.Characters(i, 1).Font.ColorIndex = 3 'rouge
    End If
  Next
Next
End Sub

Fichier joint.

A+

 

[job75]

Re : Comparaison entre 2 cellules/column

Bonjour Achil,

Notez que si les textes à comparer sont de longueurs différentes il faut prévoir 2 résultats.

Avec la solution des tris préalables :

Sub Comparer()
Dim h As Long, cel As Range, i As Integer
'---initialisation---
Application.ScreenUpdating = False
[F2:G65536].ClearContents
[F2:G65536].Font.Bold = False
[F2:G65536].Font.ColorIndex = xlAutomatic
h = Application.Max([C65536].End(xlUp).Row, [E65536].End(xlUp).Row) - 1
If h = 0 Then Exit Sub
'---tris préalables---
[A:E].Sort [A1], , [B1], Header:=xlYes
[D:D].Insert: [A:A].Copy [D1]
[D:F].Sort [D1], , [E1], Header:=xlYes
[D:D].Delete
'---remplissage des colonnes F et G---
[F2].Resize(h) = [C2].Resize(h).Value
[G2].Resize(h) = [E2].Resize(h).Value
'---comparaison des colonnes F et G---
For Each cel In [F2].Resize(h)
  For i = 1 To Application.Max(Len(cel.Text), Len(cel.Offset(, 1).Text))
    If Mid(cel.Text, i, 1) <> Mid(cel.Offset(, 1).Text, i, 1) Then
      cel.Characters(i, 1).Font.Bold = True 'gras
      cel.Characters(i, 1).Font.ColorIndex = 3 'rouge
      cel.Offset(, 1).Characters(i, 1).Font.Bold = True
      cel.Offset(, 1).Characters(i, 1).Font.ColorIndex = 3
    End If
  Next
Next
End Sub

Fichier (2).

A+