Discussion :

[tseai]

Bonjour!
J'ai cherché moi-même, puis dans divers forums, mais je n'ai rien trouvé. Qui peut m'aider?
En VBA Excel, je veux comparer 2 chaines de caractères et mettre en surbrillance ou en gras, ou en souligné (peu importe) le ou les caractères différents.
Je ne sais pas faire... Merci pour votre aide!

[Invité]

Bonjour,


Une solution possible avec cette fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Function ComparerLesChaines(ByVal ChaineReference As String, ByVal ChaineAComparer As String) As String
 
Dim I As Integer
Dim Substitut As String
Dim ChaineExacte As Boolean
 
         Application.Volatile
 
         ComparerLesChaines = "Commun : "
         Substitut = "-"
         ChaineExacte = True
 
 
         Select Case Len(ChaineAComparer)
                Case Is > Len(ChaineReference)
                     For I = 1 To Len(ChaineReference)
                         If Mid(ChaineReference, I, 1) = Mid(ChaineAComparer, I, 1) Then
                            ComparerLesChaines = ComparerLesChaines & Substitut
                         Else
                            ComparerLesChaines = ComparerLesChaines & Mid(ChaineAComparer, I, 1)
                         End If
                     Next I
                     ComparerLesChaines = ComparerLesChaines & "   En trop : " & Mid(ChaineAComparer, Len(ChaineReference) + 1)
                     ChaineExacte = False
                Case Len(ChaineReference)
                     For I = 1 To Len(ChaineReference)
                         If Mid(ChaineReference, I, 1) = Mid(ChaineAComparer, I, 1) Then
                            ComparerLesChaines = ComparerLesChaines & Substitut
                         Else
                            ComparerLesChaines = ComparerLesChaines & Mid(ChaineAComparer, I, 1)
                            ChaineExacte = False
                         End If
                     Next I
                Case Is < Len(ChaineReference)
                     For I = 1 To Len(ChaineAComparer)
                         If Mid(ChaineReference, I, 1) = Mid(ChaineAComparer, I, 1) Then
                            ComparerLesChaines = ComparerLesChaines & Substitut
                         Else
                            ComparerLesChaines = ComparerLesChaines & Mid(ChaineAComparer, I, 1)
                        End If
                     Next I
                     ComparerLesChaines = ComparerLesChaines & "   En moins : " & Mid(ChaineReference, Len(ChaineAComparer) + 1)
                     ChaineExacte = False
         End Select
 
         If ChaineExacte = True Then ComparerLesChaines = "Exact"
 
 
End Function

Le résultat de la comparaison ne modifie pas la chaîne comparée comme vous le demandiez. En revanche, vous avez le choix de visualiser le résultat dans une cellule les écarts ou de l'utiliser dans un traitement (valeur égale ou différente d' "Exact").
Le résultat de la chaîne composée du même nombre de caractères est indiqué derrière le mot : "Commun". En cas d'écart en plus ou en moins sur le nombre de caractères, les caractères sont collectés derrière les mots "En trop" ou "En moins".
Les caractères communs sont remplacés par un caractère de substitution défini en début de fonction.

Cordialement.

[tseai]

Merci Kergresse!
Mais ça n'est pas simple!!!
Mais ça marche! merci encore.

[davido84]

Bonjour,
à tester, compléter et adapter à ton fichier :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub CompareChaines()
Dim Pl As Range, i As Long, j As Long
Set Pl = Range("A11:B" & Range("A" & Rows.Count).End(xlUp).Row) 'plage contenant les valeurs à adapter
Pl.Columns(2).Font.Bold = False
 
For i = 1 To Pl.Rows.Count
 
  For j = 1 To Len(Pl.Cells(i, 1))
    If Mid(Pl.Cells(i, 1), j, 1) <> Mid(Pl.Cells(i, 2), j, 1) Then
      Pl.Cells(i, 2).Characters(Start:=j, Length:=1).Font.Bold = True
    End If
  Next j
 
  If Len(Pl.Cells(i, 2)) > Len(Pl.Cells(i, 1)) Then _
  Pl.Cells(i, 2).Characters(Start:=j, Length:=Len(Pl.Cells(i, 2)) - Len(Pl.Cells(i, 1))).Font.Bold = True
Next i
 
End Sub

A+

[tseai]

Merci Davido84!

[patricktoulon]

et pour ganier en reactivité on ajoute le test si = dans la boucle j

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub CompareChaines()
Dim Pl As Range, i As Long, j As Long
Set Pl = Range("A11:B" & Range("A" & Rows.Count).End(xlUp).Row) 'plage contenant les valeurs à adapter
Pl.Columns(2).Font.Bold = False
 
For i = 1 To Pl.Rows.Count
 
  For j = 1 To Len(Pl.Cells(i, 1))
    if Pl.Cells(i, 1)=Pl.Cells(i, 2) then exit for 
If Mid(Pl.Cells(i, 1), j, 1) <> Mid(Pl.Cells(i, 2), j, 1) Then
      Pl.Cells(i, 2).Characters(Start:=j, Length:=1).Font.Bold = True
    End If
  Next j
 
  If Len(Pl.Cells(i, 2)) > Len(Pl.Cells(i, 1)) Then _
  Pl.Cells(i, 2).Characters(Start:=j, Length:=Len(Pl.Cells(i, 2)) - Len(Pl.Cells(i, 1))).Font.Bold = True
Next i
 
End Sub