Comparaison de textes similaires sur deux colonnes

M

matteopacino

XLDnaute Junior
Bonjour,

Après une journée entière de recherche sur différent forums, je ne trouve pas la solution à mon problème...

J'ai une colonne A contenant du texte par exemple, dans cet ordre là :

Thomas
Marc
Fabienne
Murielle
Pierre
...etc
et une colonne B contenant dans l'ordre suivant :

Fab
Tom
Marc-André
Pierre
...etc

Mon souci est le suivant: est-il possible de comparer les deux colonnes et d'avoir un résultat de ce type là:

Colonne A Colonne B
Fabienne Fab
Thomas Tom
Marc Marc-André

etc...

P.S : je ne peux pas trier les listes au début.
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Bonjour matteopacino,

Voyez ce code dans Module1 du fichier joint (Alt+F11) :

Code: 
Option Compare Text 'pour que la casse soit ignorée

Sub Comparer()
Dim t1, t2, ub&, t3$(), i&, t$, j&, n&
t1 = Range("A1", Cells(Rows.Count, 1).End(xlUp))
t2 = Range("B1", Cells(Rows.Count, 2).End(xlUp))
ub = UBound(t2)
For i = 1 To UBound(t1)
  t = t1(i, 1)
  For j = 1 To ub
    If InStr(t, t2(j, 1)) Or InStr(t2(j, 1), t) Then
      ReDim Preserve t3(n)
      t3(n) = t & " " & t2(j, 1)
      n = n + 1
    End If
  Next
Next
Range("C2:C" & Rows.Count).ClearContents 'RAZ
If n Then [C2].Resize(n) = Application.Transpose(t3)
End Sub
Nota : Application.Transpose ne fonctionne pas si le tableau t3 a plus de 65536 éléments.

A+
 

Pièces jointes

  • Comparaison(1).xls
    41 KB · Affichages: 53
  • Comparaison(1).xls
    41 KB · Affichages: 52
  • Comparaison(1).xls
    41 KB · Affichages: 57
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Re,

Si le tableau t3 a plus de 65536 éléments on fait la transposition par une boucle :

Code: 
Option Compare Text 'pour que la casse soit ignorée

Sub Comparer()
Dim t1, t2, ub&, i&, t$, j&, t3$(), n&, restit$()
t1 = Range("A1", Cells(Rows.Count, 1).End(xlUp))
t2 = Range("B1", Cells(Rows.Count, 2).End(xlUp))
ub = UBound(t2)
For i = 1 To UBound(t1)
  t = t1(i, 1)
  For j = 1 To ub
    If InStr(t, t2(j, 1)) Or InStr(t2(j, 1), t) Then
      ReDim Preserve t3(n)
      t3(n) = t & " " & t2(j, 1)
      n = n + 1
    End If
  Next
Next
Range("C2:C" & Rows.Count).ClearContents 'RAZ
If n Then
  ReDim restit(n - 1, 0)
  For i = 0 To n - 1
    restit(i, 0) = t3(i)
  Next
  [C2].Resize(n) = restit
End If
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Comparaison(2).xls
    41.5 KB · Affichages: 48
Dernière édition:
Vote positif 0 Vote négatif
M

matteopacino

XLDnaute Junior
Re : Comparaison de textes similaires sur deux colonnes

Rebonjour Job75,

cela fonctionne bien, cependant , pourrait t'on avoir les résultats dans des colonnes différentes ?

Je m'explique :
Colonne A colonne B
Marco Fab
Pierre Marc-andré
Fabienne Pierrot
...etc


qui donnerait après la macro :

Colonne C Colonne D

Marco Marc-André
Pierre Pierrot
fabienne Fab
...etc


merci beaucoup pour votre aide
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Re,

Ah NON, pour Marco ou Pierrot on ne peut rien faire (de simple) :rolleyes:

Pour 2 colonnes là c'est simple : un tableau t4 en plus :

Code: 
Option Compare Text 'pour que la casse soit ignorée

Sub Comparer()
Dim t1, t2, ub&, i&, t$, j&, t3$(), t4$(), n&, resu$()
t1 = Range("A1", Cells(Rows.Count, 1).End(xlUp))
t2 = Range("B1", Cells(Rows.Count, 2).End(xlUp))
ub = UBound(t2)
For i = 1 To UBound(t1)
  t = t1(i, 1)
  For j = 1 To ub
    If InStr(t, t2(j, 1)) Or InStr(t2(j, 1), t) Then
      ReDim Preserve t3(n)
      ReDim Preserve t4(n)
      t3(n) = t
      t4(n) = t2(j, 1)
      n = n + 1
    End If
  Next
Next
Range("C2:D" & Rows.Count).ClearContents 'RAZ
If n Then
  ReDim resu(n - 1, 1)
  For i = 0 To n - 1
    resu(i, 0) = t3(i)
    resu(i, 1) = t4(i)
  Next
  [C2:D2].Resize(n) = resu
End If
End Sub
Fichier (3).

A+
 

Pièces jointes

  • Comparaison(3).xls
    41.5 KB · Affichages: 58
Vote positif 0 Vote négatif
R@chid

R@chid

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Bonsoir @ tous,
par formule...
Amicalement
 

Pièces jointes

  • Comparaison.xlsm
    24.6 KB · Affichages: 67
  • Comparaison.xlsm
    24.6 KB · Affichages: 69
  • Comparaison.xlsm
    24.6 KB · Affichages: 61
Dernière édition:
Vote positif 0 Vote négatif
M

matteopacino

XLDnaute Junior
Re : Comparaison de textes similaires sur deux colonnes

Bonjour Racid, Bonjour le fil,

merci pour cette formule.

Cependant, je vais préciser ma demande.

En fait, je vous mets en pièce jointe le document que vous aviez crée. Il s'agit tout simplemenet de garder la même fonctionnalité, mais avec des termes entre la colonne A de Nom1 et la colonne A de nom2 qui ne sont pas exactement pareils. Disons qu'il peut y avoir sur un terme de 6 mots, 4 qui sont semblables seulement.

Par exemple :

nom 1 / Colonne A : Prochain film de starwars

nom2 / colonne B : film de starwars a venir

Pensez-vous que ce soit possible de modifier la formule ?

cordialement
 

Pièces jointes

  • YesOfCourse.xls
    25.5 KB · Affichages: 43
  • YesOfCourse.xls
    25.5 KB · Affichages: 46
  • YesOfCourse.xls
    25.5 KB · Affichages: 45
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Bonjour matteopacino, R@chid, le forum,

Bravo R@chid pour ta solution par formule :)

Un peu pour le fun, un essai traitant les 4 premiers caractères des noms :

Code: 
Option Compare Text 'pour que la casse soit ignorée

Sub Comparer()
Dim t1, t2, ub&, d As Object, i&, u$, x$, j&, v$, y$
Dim resu$(), a, s
t1 = Range("A2", Cells(Rows.Count, 1).End(xlUp))
t2 = Range("B2", Cells(Rows.Count, 2).End(xlUp))
ub = UBound(t2)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t1)
  u = t1(i, 1)
  x = Left(u, 1) & "*" & Mid(u, 2, 1) & "*" & _
    Mid(u, 3, 1) & "*" & Mid(u, 4, 1) & "*"
  For j = 1 To ub
    v = t2(j, 1)
    y = Left(v, 1) & "*" & Mid(v, 2, 1) & "*" & _
      Mid(v, 3, 1) & "*" & Mid(v, 4, 1) & "*"
    If u Like y Or v Like x Then _
      d(u & Chr(1) & v) = u & Chr(1) & v
  Next
Next
Range("C2:D" & Rows.Count).ClearContents 'RAZ
If d.Count Then
  ReDim resu(d.Count - 1, 1)
  a = d.Keys
  For i = 0 To d.Count - 1
    s = Split(a(i), Chr(1))
    resu(i, 0) = s(0)
    resu(i, 1) = s(1)
  Next
  [C2:D2].Resize(d.Count) = resu
End If
End Sub
Pour éliminer les doublons l'objet "Dictionary" est utilisé.

Cette fois les noms Tom, Marco, Pierrot sont trouvés...

Fichier (4).

A+
 

Pièces jointes

  • Comparaison(4).xls
    44.5 KB · Affichages: 46
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Re matteopacino,

Je ne vois pas le rapport entre le fichier du post #9 et le problème posé.

Le mieux serait de joindre votre fichier réel (allégé) en indiquant ce que vous voulez comparer.

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Re,

D'après ce que je comprends du post #9 voici une recherche des mots séparés par un espace.

Seuls les mots de plus de 3 caractères sont comparés :

Code: 
Sub Comparer()
Dim t1, t2, ub&, d As Object, i&, x$, sx, ubsx%
Dim j&, y$, sy, k%, resu$()
t1 = Range("A2", Cells(Rows.Count, 1).End(xlUp)(2))
t2 = Range("B2", Cells(Rows.Count, 2).End(xlUp)(2))
ub = UBound(t2)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t1)
  x = t1(i, 1): sx = Split(x): ubsx = UBound(sx)
  For j = 1 To ub
    y = t2(j, 1)
    If Len(y) Then
      sy = Split(y)
      For k = 0 To ubsx
        If Len(sx(k)) > 3 Then _
          If IsNumeric(Application.Match(sx(k), sy, 0)) _
            Then d(x & Chr(1) & y) = x & Chr(1) & y
      Next
    End If
  Next
Next
Range("C2:D" & Rows.Count).ClearContents 'RAZ
If d.Count Then
  ReDim resu(d.Count - 1, 1)
  sx = d.Keys
  For i = 0 To d.Count - 1
    sy = Split(sx(i), Chr(1))
    resu(i, 0) = sy(0)
    resu(i, 1) = sy(1)
  Next
  [C2:D2].Resize(d.Count) = resu
End If
End Sub
Nota 1 : Application.Match ignore la casse, Option Compare Text est ici inutile.

Nota 2 : .End(xlUp)(2) pour qu'il y ait au moins 2 éléments dans chaque tableau.

Edit : mis le test sur Len(y) avant la boucle k

Fichier (5).

A+
 

Pièces jointes

  • Comparaison(5).xls
    43.5 KB · Affichages: 47
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Comparaison de textes similaires sur deux colonnes

Re,

Finalement je pense que c'est cette version (6) qui vous intéressera le plus.

Comparaison des séries de caractères dont le nombre est paramétrable :

Code: 
Option Compare Text 'pour que la casse soit ignorée

Sub Comparer(N%)
'comparaison des séries de caractères
Dim d As Object, t1, t2, ub&, i&, x$, km%
Dim j&, y$, k%, resu$()
Set d = CreateObject("Scripting.Dictionary")
If N Then
  t1 = Range("A2", Cells(Rows.Count, 1).End(xlUp)(2))
  t2 = Range("B2", Cells(Rows.Count, 2).End(xlUp)(2))
  ub = UBound(t2)
  For i = 1 To UBound(t1)
    x = Application.Trim(t1(i, 1)): km = Len(x) - N + 1
    For j = 1 To ub
      y = Application.Trim(t2(j, 1))
      For k = 1 To km
        If InStr(y, Mid(x, k, N)) Then _
          d(x & Chr(1) & y) = x & Chr(1) & y: Exit For
      Next
    Next
  Next
End If
Range("C2:D" & Rows.Count).ClearContents 'RAZ
If d.Count Then
  ReDim resu(d.Count - 1, 1)
  t1 = d.Keys
  For i = 0 To d.Count - 1
    t2 = Split(t1(i), Chr(1))
    resu(i, 0) = t2(0)
    resu(i, 1) = t2(1)
  Next
  [C2:D2].Resize(d.Count) = resu
End If
End Sub

Nota 1 : la macro est paramétrée (variable N), et lancée par cette autre macro :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [Nserie]) Is Nothing Then Comparer [Nserie]
End Sub
Nserie étant le nom de la cellule G5 affectée d'une liste de validation.

Nota 2 :J'ai bien sûr remis Option Compare Text.

Et ajouté Application.Trim : c'est la fonction SUPPRESPACE.

Edit : j'ai ajouté Exit For ce qui fait gagner du temps de calcul.

A mettre aussi au même endroit dans la macro (5) précédente.

A+
 

Pièces jointes

  • Comparaison(6).xls
    39.5 KB · Affichages: 57
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

L
  • Question
Microsoft 365 Comparer le texte de deux colonnes (plusieurs mots/cellule) pour trouver 1 mot en commun
2 3
Réponses
37
Affichages
2 K
Staple1600
Staple1600
T
  • Question
Microsoft 365 Macro vba comparaison / insertion
Réponses
8
Affichages
465
tof1584
T
L
  • Résolu(e)
XL 2019 Comparaison valeurs de deux feuilles et copier-coller des colonnes correspondantes
2
Réponses
15
Affichages
918
Lolexcel
L
L
  • Résolu(e)
XL 2016 Comparaison entre deux feuilles Excel
Réponses
12
Affichages
745
LeSaintKebab
L
samimi94
  • Question
Microsoft 365 Formule ou Macro pour comparer deux colonnes et afficher valeur manquante
Réponses
10
Affichages
1 K
Jacky67
Jacky67
A
  • Résolu(e)
XL 2016 Résolu VBA - Comparaison de cellules sur différentes feuilles
Réponses
2
Affichages
934
Archeon
A
bellenm
  • Question
Tri spécial sur les premiers caractère d'une cellule et numérotage spécifique
2
Réponses
21
Affichages
3 K
bellenm
bellenm
P
  • Question
Microsoft 365 Comparaison de tableaux !
Réponses
1
Affichages
2 K
Patrosso
P
A
  • Résolu(e)
XL 2013 VBA - Comparaison de 2 tableaux
Réponses
4
Affichages
2 K
Ananas94
A
S
  • Question
Microsoft 365 Excel ! comparaison de deux colonnes et afficher le résultat d'une autre cellule
Réponses
8
Affichages
1 K
sylvanu
sylvanu

Membres actuellement en ligne

12 membres et 110 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 492
Messages
2 088 930
Membres
103 984
dernier inscrit
maliko67