Microsoft 365 Comparer le texte de deux colonnes (plusieurs mots/cellule) pour trouver 1 mot en commun

L

Lagertha

Guest
Bonjour à tous!
Je suis toute fraîchement arrivée ici et je vous découvre en faisant mes recherches depuis plusieurs jours sur ma problématique.
Je n'y ai pas encore trouvé de solution. Je vous l'expose en espérant que vos lumière me sauveront.

Je pars d'une liste de noms de dossier en colonne A (environ 22 000 lignes)

J'ajoute en colonne B, quotidiennement, une liste de dossiers qui me vient de l'internationale pour vérifier que nous n'avons pas les mêmes clients pour des missions qui seraient en conflit. Cette liste ne contient pas plus de 50 lignes.

La difficultés: chaque cellule de la colonne A et B comprend plusieurs mots (nom de la société, parfois la branche de la filiale, ...).
Il me faut tester chaque cellule de la colonne B pour vérifier qu'au moins un mot ne se trouve pas dans ma colonne A. Je ne cherche donc pas des cellules identiques (donc pas de RECHERCHE, etc...) mais des cellules qui auraient au moins un mot en commun (sans tenir compte de la casse).
J'ai testé quelques macros trouvées sur le site mais elles ne permettent la comparaison que de deux cellules de la même ligne. Je suis vraiment perdue.

Exemple joint.

Je vous remercie par avance pour toute l'aide que vous pourriez m'apporter
 

Pièces jointes

  • Comparaison des deux colonnes.xlsx
    9.2 KB · Affichages: 14
Dernière modification par un modérateur:

Lolote83

XLDnaute Barbatruc
Bonjour @Lagertha et bienvenue sur le forum
L’idéal serait de joindre un exemple du fichier en question (quelques lignes) qui expliquent ce que tu recherches avec éventuellement des informations saisies actuellement à la main pour nous aiguiller plus facilement
Attention, le fichier à joindre ne doit pas contenir d'informations confidentielles.
Donc, dans l'attente d'un retour de fichier, on aura plus facilement la possibilité de te donner une solution
Cordialement
Lolote83
 
L

Lagertha

Guest
Excusez moi, je pensais que l'exemple que j'avais mis allait garder sa mise en forme mais c'est illisible.
Je joins un fichier ici pour plus de compréhension. @Lolote83 @djidji59430
 

Pièces jointes

  • Comparaison des deux colonnes.xlsx
    9.2 KB · Affichages: 27
Dernière modification par un modérateur:
L

Lagertha

Guest
@Lolote83 Merci beaucoup, j'admire la rapidité avec laquelle vous avez fait ça.

Pour ne pas commettre d'erreur, afin d'adapter cette macro à mon tableau dont la liste colonne A fait 22000 lignes et la liste colonne B fait 50 lignes, je dois faire ces modifications dans le module:

Sub ChercheMot()
Dim xTablo
For Each xCell_ColB In Range("B2:B7") -> ("B2:B50")
xMot = xCell_ColB.Value
xDecoupe = Split(xMot, " ")
For F = 0 To UBound(xDecoupe)
xMot = xDecoupe(F)
For Each xCell_ColA In Range("A2:A9") -> ("A2:A22000")
If InStr(1, xCell_ColA, xMot) > 0 Then
xCpt = xCpt + 1
Range("F" & xCpt + 1) = xMot & " trouvé en cellule A" & xCell_ColA.Row
End If
Next xCell_ColA
Next F
Next xCell_ColB
End Sub

C'est bien ça?

Aussi, la difficulté, c'est que ça ne trouve pas que les mots communs mais également les petits bouts de mot en commun, type "BV" entre "LEFEBVRE" colonne A et "ABVI" colonne B par exemple. Y a-t-il une solution à cela?
 
Dernière modification par un modérateur:

Lolote83

XLDnaute Barbatruc
Bonjour
Oui, il faut remplacer les valeurs telles que décrites dans votre post#6
Par contre, le traitement sera très très long vue le nombre de lignes.
On pourrait alors faire apparaitre une barre de défilement qui donne le % en attendant la fin du traitement.
Par contre, pas le temps ce soir.
Attention, il faut aussi que les mots soient séparé par un espace dans la colonne B sinon cela ne fonctionnera pas.
Dites moi, et demain vous aurez alors une version avec barre de défilement.
@+ Lolote83
 
L

Lagertha

Guest
Bonjour @Lolote83 ,
Merci pour votre réponse. Oui les mots, e, colonne A et B, sont bien séparés par un espace.
L'outil devient intéressant et pertinent lorsqu'il repère un mot complet en commun.

Je confirme qu'au vu des premiers essais, le temps de recherche est un peu long mais cela ne me gène pas.
Ce qui est compliqué, c'est qu'en trouvant pour résultat jusqu'à 2 lettres en commun, la liste de résultats fait 80 000 lignes 😅
 

Lolote83

XLDnaute Barbatruc
Re bonjour @Lagertha,
Voici la Version 3 qui normalement prend en compte uniquement l'exactitude des mots.
Aussi, la difficulté, c'est que ça ne trouve pas que les mots communs mais également les petits bouts de mot en commun, type "BV" entre "LEFEBVRE" colonne A et "ABVI" colonne B par exemple. Y a-t-il une solution à cela?
Je pense qu'avec cette version, la demande devrait du coup mieux correspondre.
A tester.
Merci du retour
Cordialement
Lolote83
 

Pièces jointes

  • Copie de LAGERTHA - Comparaison des deux colonnes_V3.xlsm
    34.9 KB · Affichages: 13

laurent950

XLDnaute Barbatruc
Bonsoir @Lagertha @Lolote83 @djidji59430

Copier en colonne A : vos liste de noms de dossier (environ 22 000 lignes)
Copier en colonne B : vos liste de noms de dossier de l'internationale (environ 50 lignes)

Le Programme ci-dessous fait tous le reste.
Au Plaisir de vous lire et de connaitre votre retour.

Cela devrait être super rapide en temps de traitement pour 80 000 Ligne en colonne A

Pour info en retour, combien de temps pour le traitement de la colonne A ?
Combien de Ligne en Colonne A = ?
Combien de Ligne en Colonne B = ?
j'ai vraiment optimisé pour que cela soit Ultra Rapide !

Module Standard(ModStandardColl)
VB:
Option Explicit
Sub FindPatternInRangeColor()
' A Partir de la Lignes 2 Colonne A et B
' Colonne A (Coller la Liste de + 20 000 Lignes)
' Colonne B (Coller La Liste de + 50 Lignes)
' Test :
' Pour Chaques cellule de la colonne B
'   Alors Chaque mot de cette cellule
'   Sera comparer a tous les Mots de toutes les céllule de la colonne A
'   Exemple :
'       - Cellule B7 = 2 Mots ---->> "Ani Tan"
'               - Alors : le resulat [Tan] Lig N° : 13; [Ani] Lig N° : 13; 14; 15
'     En Colonne A --->>> Tan ce trouve en Ligne 13 et Ani ce trouve en Ligne 13 ; 14 et 15
'     En Colonne B ce qui est trouvé en Colonne A est Colorié en Rouge pour le Texte
'   Alors en
'     En Colonne A --->>> Tan ce trouve en Ligne 13 le Mot Tan est colorié en Rouge
'     En Colonne A --->>> Ani ce trouve en Ligne 13; 14; 15 les Mots Ani sont colorié en Rouge
'
    Dim t ' .................................. 0
    Dim ws As Worksheet ' ............................ 1
    Dim rng As Range ' ............................... 2
    Dim Res As ModClasseColl ' ....................... 3
    Dim Val As Range ' ............................... 4
    Dim TDon As Variant ' ............................ 5
    Dim j As Byte ' .................................. 6
    Dim Lig As String ' .............................. 8
    Dim Col As Collection ' .......................... 9
    Dim élément As ModClasseColl ' ................... 10
    Dim regex As Object ' ............................ 11
    Dim pattern As String ' .......................... 12
    Dim matches As Object ' .......................... 13
    Dim match As Object ' ............................ 14
    Dim cell As Range ' .............................. 15
    Dim Tcolor() As Range ' .......................... 16
    Dim k As Long ' .................................. 17
    Dim Separator As String ' ........................ 18
    Dim startPos As Long ' ........................... 19
    Dim endPos As Long ' ............................. 20
    Dim Progress As Long ' ........................... 21
    Dim ZoneTraité As String ' ....................... 22
    Dim CptColProgsBarre As Long ' ................... 23
    Dim TabLigColA() As String ' ..................... 23
    Dim MotTabLigColA As String ' .................... 23
 
    Application.ScreenUpdating = False
 
    ' 0) Spécifiez le temps de traitement des données
        t = Timer
 
    ' 1) Spécifiez la feuille de calcul et la plage dans laquelle vous souhaitez rechercher
        Set ws = ThisWorkbook.Worksheets(ActiveSheet.Name)
 
    ' 2) Changer cette plage en fonction de vos besoins
        Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(ws.Cells(1048576, 1).End(xlUp).Row, 2))
 
    ' 9) La collection qui contient le Module de Classe
            Set Col = New Collection
       
    ' ** ) Barre de progression
           Progress = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1 ' ......... Comptes les élèments
           'UserForm1.Show vbModeless ' ....................................... Affiche la UserForm en mode non modal
           UsfProgressBarr.Show vbModeless ' ................................. Affiche la UserForm en mode non modal
           ZoneTraité = " Part 1/2 : Scan tous les Mots de la colonne A" ' ... Partie Traité
 
    ' *) 4 = Val | 5 = TDon | 6 = j | 7 = Lig | 3 = Res
            For Each Val In rng.Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1, 1)
                TDon = Split(Trim(Val.Value), " ")
                    For j = LBound(TDon) To UBound(TDon)
                        ' Gestion d'erreur
                        On Error Resume Next
                            If Exists(Col, TDon(j)) = False Then
                                ' Le Module de Classe
                                    Set Res = New ModClasseColl
                                ' Remplire Le Module de Classe
                                    Res.Col = Split(Val.Address, "$")(1) ' ....... Colonne Lettre (du Mot)
                                    Res.Lig = CStr(Val.Row) ' .................... Ligne N° (du Mot)
                                Set Res.Add = Val ' .............................. Adresse Ligne (du Mot)
                                    Res.Key = TDon(j) ' .......................... Le Mot (du Mot)
                                    Res.Init ' ................................... Remplis le Tableau Ligne et Adresse
                                ' Stock le Module de Classe dans la collection
                                    Col.Add Item:=Res, Key:=TDon(j) ' ........... MetaDonnées Mot Colonne A
                            Else
                                ' Le Module de Classe
                                    Set Res = Col.Item(TDon(j))
                                ' Stock le Module de Classe dans la collection
                                ' Provoque une erreur
                                ' Modifier et Remplire Le Module de Classe avec les nouvelles valeurs
                                    Col.Add Item:=Res, Key:=TDon(j) ' ......................... N
                                        If Err <> 0 Then
                                            'Lig = Res.Lig & "; " & Val.Row ' ......... Les Numéros des Ligne (du Mot) ' Res.Lig Mange trop de mémoire
                                            'Res.Lig = Lig ' ........................... Ligne N° (du Mot) ' Res.Lig Mange trop de mémoire
                                            Res.Lig = CStr(Val.Row) ' .................... Ligne N° (du Mot)
                                        Set Res.Add = Val ' ....................... Adresse Ligne (du Mot)
                                            Res.Init ' ................................ Remplis le Tableau Ligne et Adresse
                                            Col.Remove (TDon(j))
                                            Col.Add Item:=Res, Key:=TDon(j)
                                            Lig = Empty
                                        End If
                            On Error GoTo 0
                            End If
                    Next j
            ' Met à jour la barre de progression
            'UserForm1.UpdateProgressBar Val.Row / Progress, ZoneTraité
             UsfProgressBarr.UpdateProgressBar Val.Row, Progress, ZoneTraité
            Next Val
            On Error GoTo 0
       
'   Ferme la UserForm lorsque la macro est terminée
            'Unload UserForm1
            Unload UsfProgressBarr
            Progress = Empty: ZoneTraité = Empty

'   Efface le précedent resultat de la colonne B
        rng.Offset(, 2).Resize(ws.Cells(ws.Rows.Count, 2).End(xlUp).Row - 1, 1).Clear

'   Efface le précedent Format des cellule en Rouge resultat de la colonne A
        rng.Offset(, 0).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1, 1).Interior.ColorIndex = xlNone
        rng.Offset(, 0).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1, 1).Font.ColorIndex = xlAutomatic

'   Efface le précedent Format des cellule en Rouge resultat de la colonne B
        rng.Offset(, 1).Resize(ws.Cells(ws.Rows.Count, 2).End(xlUp).Row - 1, 1).Interior.ColorIndex = xlNone
        rng.Offset(, 1).Resize(ws.Cells(ws.Rows.Count, 2).End(xlUp).Row - 1, 1).Font.ColorIndex = xlAutomatic

    ' ** ) Barre de progression
           Progress = Col.Count ' ......... Comptes les élèments
           'UserForm1.Show vbModeless ' ....................................... Affiche la UserForm en mode non modal
           UsfProgressBarr.Show vbModeless ' ....................................... Affiche la UserForm en mode non modal
           ZoneTraité = " Part 2/2 : Identifie les Mots de la colonne B Présent dans Colonne A" ' ... Partie Traité

'   Parcourir tous les éléments du dictionnaire
    For Each élément In Col
        CptColProgsBarre = CptColProgsBarre + 1
        Set Res = élément ' ................................................. Le Module de Classe
            pattern = Res.Key ' ............................................. Spécifiez le motif (pattern) que vous recherchez
        Set regex = CreateObject("VBScript.RegExp") ' ....................... Créez un objet RegExp
            With regex
                .Global = True ' ............................................ Recherchez toutes les correspondances dans chaque cellule
                .IgnoreCase = True ' ........................................ Ignorez la casse (en fonction de vos besoins)
                .pattern = pattern ' ........................................ Le Pattern (Ici le Mot)
            End With
'
'       Bouclez à travers chaque cellule dans la plage de la colonne A
'       rng.Offset(, 1).Resize(ws.Cells(ws.Rows.Count, 2).End(xlUp).Row - 1, 1).Select
            For Each cell In rng.Offset(, 1).Resize(ws.Cells(ws.Rows.Count, 2).End(xlUp).Row - 1, 1)
                TDon = Split(Trim(cell.Value), " ") ' ........................... Découpage de la chaine / " "
                    For j = LBound(TDon) To UBound(TDon)
                        Set matches = regex.Execute(TDon(j)) ' .................. Recherchez des correspondances dans le contenu de la cellule
'
'                           Vérifiez si des correspondances ont été trouvées
                            If matches.Count > 0 Then
'                               Traitez les correspondances ici
'                               Par exemple, vous pouvez afficher les correspondances dans la fenêtre de l'IDE
                                For Each match In matches
                                    'Debug.Print "Correspondance trouvée dans la cellule " & cell.Address & ": " & match.Value
                                    ' 1)
                                    ' Trouvé en Colonne A sur les Numéro de ligne
                                        TabLigColA = Res.Tlig
                                        ReDim Preserve Tcolor(UBound(TabLigColA) - 1)
                                        MotTabLigColA = Join(TabLigColA, "; ")
                                        MotTabLigColA = Left(MotTabLigColA, Len(MotTabLigColA) - 2)
                                    ' Définissez le séparateur
                                      Separator = "; "
                                        If cell.Offset(, 1).Value <> "" Then
                                            cell.Offset(, 1).Value = cell.Offset(, 1).Value & Separator
                                        End If
                                        cell.Offset(, 1).Value = cell.Offset(, 1).Value & "[" & TDon(j) & "] Lig N° : " & MotTabLigColA ' Res.Lig Mange trop de mémoire
                                    ' 2)
                                    ' Option : Format Text cellule de la colonne A
                                    '  Mettez en couleur la correspondance dans la cellule de la colonne A
                                    '  Obtenez les positions de début et de fin de la correspondance dans la cellule
                                    '  A l'aide du tableau d'adresse Res.TAdd
                                        Tcolor = Res.TAdd
                                        ReDim Preserve Tcolor(UBound(Tcolor) - 1)
                                        For k = LBound(Tcolor) To UBound(Tcolor)
                                            startPos = InStr(1, Tcolor(k).Value, match.Value, vbTextCompare)
                                            endPos = startPos + Len(match.Value) - 1
                                    ' Mettez en couleur la correspondance dans la cellule
                                            Tcolor(k).Characters(startPos, Len(match.Value)).Font.Color = RGB(255, 0, 0) ' Couleur rouge
                                        Next k
'                                 ' 3)
                                    ' Option : Format Text cellule de la colonne B
                                            startPos = InStr(1, cell.Value, match.Value, vbTextCompare)
                                            endPos = startPos + Len(match.Value) - 1
                                    ' Mettez en couleur la correspondance dans la cellule
                                            cell.Characters(startPos, Len(match.Value)).Font.Color = RGB(255, 0, 0) ' Couleur rouge
                                Next match
                            End If
                    Next j
            Next cell
        ' Met à jour la barre de progression
        'UserForm1.UpdateProgressBar CptColProgsBarre / Progress, ZoneTraité
        UsfProgressBarr.UpdateProgressBar CptColProgsBarre, Progress, ZoneTraité
    Next élément
'   Ferme la UserForm lorsque la macro est terminée
        'Unload UserForm1
        Unload UsfProgressBarr
        Progress = Empty: ZoneTraité = Empty
'
   MsgBox Timer - t
Application.ScreenUpdating = True
End Sub
'
Function Exists(ByRef Col As Collection, ByVal Key As String) As Boolean
' Le code suivant vérifie si une clé existe
    On Error GoTo EH
    IsObject (Col.Item(Key))
    Exists = True
EH:
End Function

Module de Classe(ModClasseColl)
Code:
Option Explicit
Private mCol As String
Private mLig As String
Private mAdd As Range
Private mKey As String
Private mTlig() As String
Private mTAdd() As Range
' ***************************************************************************************************************************
Property Get Col() As String
' Renvoi la valeur de la colonne
   Col = mCol
End Property
Property Let Col(ByVal NewValue As String)
' Mise à jour la valeur de la colonne
   mCol = NewValue
End Property
'
Property Get Lig() As String
' Renvoi la valeur de la colonne
   Lig = mLig
End Property
Property Let Lig(ByVal NewValue As String)
' Mise à jour la valeur de la colonne
   mLig = NewValue
End Property
'
Property Get Add() As Range
' Renvoi la valeur de la colonne
  Set Add = mAdd
End Property
Property Set Add(ByVal NewValue As Range)
' Mise à jour la valeur de la colonne
  Set mAdd = NewValue
End Property
'
Property Get Key() As String
' Renvoi la valeur du Mot recherché
   Key = mKey
End Property
Property Let Key(ByVal NewValue As String)
' Mise à jour de la valeur du Mot recherché
   mKey = NewValue
End Property
' ===========================================================================================================================
Property Get Tlig() As String()
' Renvoi la valeur du numéro de ligne du Mot recherché
   Tlig = mTlig
End Property
'
Property Get TAdd() As Range()
' Renvoi la valeur de l'adresse du Mot recherché
   TAdd = mTAdd
End Property
' ===========================================================================================================================
Private Sub Class_Initialize()
    ReDim Preserve mTlig(0 To 0)
    ReDim Preserve mTAdd(0 To 0)
End Sub
'
Public Sub Init()
' Mise à jour de la valeur du numéro de ligne du Mot recherché
        mTlig(UBound(mTlig)) = Me.Lig
' Mise à jour de la valeur la valeur de l'adresse du Mot recherché
   Set mTAdd(UBound(mTAdd)) = Me.Add
' Dimenssion des tableau
    ReDim Preserve mTlig(0 To UBound(mTlig) + 1)
    ReDim Preserve mTAdd(0 To UBound(mTAdd) + 1)
End Sub
'
Private Sub Class_Terminate()
    ' Code de nettoyage à effectuer ici

    ' Par exemple, vous pouvez réinitialiser les propriétés de la classe
    mCol = Empty
    mLig = Empty
    Set mAdd = Nothing
    mKey = Empty
 
    ' Libérer les tableaux
    Erase mTlig
    Erase mTAdd
End Sub

UserForm Progress Barre Label Name : (UsfProgressBarr)
Part 1 (UsfProgressBarr)
Code:
Private Sub UserForm_Initialize()
    ' Initialisez la barre de progression (Label) avec une couleur de fond et une largeur nulle
    LabelProgressBar.Width = 0
    LabelProgressBar.BackColor = RGB(0, 128, 0) ' Couleur de fond verte initiale
End Sub

Part 2 (UsfProgressBarr)
Code:
Sub UpdateProgressBar(CurrentProgress As Long, MaxProgress As Long, ByVal Zone As String)
    ' Mettez à jour la barre de progression (Label) en fonction de la valeur de progression (0 à 100)
    Dim ProgressPercentage As Double
    ProgressPercentage = CurrentProgress / MaxProgress
 
    ' Calculez la nouvelle largeur du Label pour représenter la progression
    Me.LabelProgress.Caption = "Progression : " & Format(ProgressPercentage, "0%") & Zone
    Me.LabelProgressBar.Width = ProgressPercentage * Me.Width
 
    DoEvents ' Permet de rafraîchir l'interface utilisateur
End Sub

Laurent950
 

Pièces jointes

  • AvecNumLigne_ComparaisonDesDeuxColonnes-Regex-ColorTxt-Adresse(ComplexeModuledeClasse).xlsm
    44.6 KB · Affichages: 9
Dernière édition:

RyuAutodidacte

XLDnaute Impliqué
Bonsoir le fil,

Une autre version différente de mes collègues Excéliens
(Si j'ai bien compris le problème)
Tester les 2 feuilles svp

PS : la macro pointe sur la feuille active
VB:
ActiveSheet
Pour pointer sur la feuille voulue remplacer ActiveSheet par Sheet("NomDeLaFeuille"), dans tout le code …
Ex. :
VB:
     VA = ActiveSheet.Cells(1).CurrentRegion.Value
deviendra :
VB:
     VA = Sheet("Feuil1").Cells(1).CurrentRegion.Value

Le code :
VB:
Option Explicit

Sub FindWords()
Dim Wd As New Collection, VA, LRowB As Integer, V, x As Long, y As Integer, L As String, T!
 
    T = Timer
 
    VA = ActiveSheet.Cells(1).CurrentRegion.Value
    LRowB = Application.CountA(ActiveSheet.Cells(1).CurrentRegion.Offset(, 1).Resize(, 1))
 
    For x = 2 To UBound(VA)
        V = Split(Application.Trim(VA(x, 1)))
        L = "CLIENT "
        For y = LBound(V) To UBound(V)
            On Error Resume Next
            Wd.Add L, V(y)
            If Err Then Err.Clear
        Next
    Next
 
    For x = 2 To LRowB
        V = Split(Application.Trim(VA(x, 2)))
        L = ""
        For y = LBound(V) To UBound(V)
            On Error Resume Next
                L = Wd(V(y)) & "OK"
            If Err Then Err.Clear
        Next
        If Len(L) = 0 Then L = "RISQUE DE CONFLIT - CLIENT NOK"
        VA(x, 3) = L
    Next
 
    VA = Application.Index(VA, Application.Evaluate("Row(" & 2 & ":" & LRowB & ")"), 3)
 
Application.ScreenUpdating = False
    ActiveSheet.Cells(2, 3).Resize(UBound(VA), 1).Value = VA
Application.ScreenUpdating = True
 
    MsgBox Format(Timer - T, "0.0000s")
 
End Sub

Le fichier :
 

Pièces jointes

  • Comparaison des deux colonnes.xlsm
    153 KB · Affichages: 9
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir @Lagertha :), à tous ;),

J'avais commencé donc j'ai repris pour terminer et je publie malgré les excellents réponses déjà données.
Au lieu de "ok", on met dans la cellule la liste des contrats nationaux susceptibles de correspondre au dossier international de la ligne.
Une constante au début du code nommée "TailleMin = 3" fixe la longueur minimum pour prendre en compte un mot. Ici on ne considère que les mots d'au moins 3 caractères. On espère ainsi éliminer les articles. Vous pouvez modifier cette constante.
Le code se trouve dans le module associé à la feuille "Feuil1". Dans ce code, vous pouvez supprimer la procédure INIT() ainsi que le bouton orange "INIT" sur la feuille "Feuil1" et la feuille "INIT" elle-même. Ils ne sont là que pour les tests. Seule la procédure Sub Comparer() et la déclaration de la constante sont indispensables.
L'exécution est assez rapide. Cependant, l'utilisation de dictionary dans le code restreint sa validité aux PC et non aux machines de la pomme!

Le code dans le module de Feuil1 :
VB:
Const TailleMin = 3     ' nombre de lettre minimum pour prendre en compte les mots

Sub Comparer()
Dim dera&, derb&, dicoa, ta, tb, i&, x, deb
   deb = Timer
   If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
   dera = Cells(Rows.Count, "a").End(xlUp).Row: derb = Cells(Rows.Count, "b").End(xlUp).Row
   If dera = 1 Or derb = 1 Then Exit Sub
   Set dicoa = CreateObject("Scripting.Dictionary")
   dicoa.CompareMode = TextCompare
   ta = Range("a2:a" & dera): tb = Range("b2:b" & derb): ReDim tr(1 To derb, 1 To 1)
   For i = 1 To UBound(ta)
      For Each x In Split(ta(i, 1))
         If Len(x) >= TailleMin Then
            If InStr(1, dicoa(x), ";" & ta(i, 1) & ";", vbTextCompare) = 0 Then dicoa(x) = dicoa(x) & ";" & ta(i, 1) & ";"
         End If
      Next x
   Next i

   For i = 1 To UBound(tb)
      For Each x In Split(tb(i, 1))
         If dicoa.Exists(x) Then tr(i, 1) = tr(i, 1) & dicoa(x)
      Next x
   Next i
   For i = 1 To UBound(tr)
      If tr(i, 1) <> "" Then tr(i, 1) = Replace(Mid(tr(i, 1), 2, Len(tr(i, 1)) - 2), ";;", "; ")
   Next i
   Application.ScreenUpdating = False
   Range("c2:c" & Rows.Count).Clear
   Range("c2").Resize(UBound(tr)) = tr
   Columns("c:c").ColumnWidth = 100
   Columns("c:c").WrapText = True
   Columns("c:c").MergeCells = False
   Range("a2:c" & Rows.Count).VerticalAlignment = xlVAlignCenter
   Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
   MsgBox "Durée : " & Format(Timer - deb, "0.00\ sec.")
End Sub
 

Pièces jointes

  • Lagertha- Compar 2 cols- v1.xlsm
    82.9 KB · Affichages: 10

RyuAutodidacte

XLDnaute Impliqué
Bonjour le fil,

@mapomme
L'exécution est assez rapide. Cependant, l'utilisation de dictionary dans le code restreint sa validité aux PC et non aux machines de la pomme!
En effet 🤣 vade retros satanas 😜 Je peux même pas essayer le code…
Heureusement qu'il y a les collections qui font MAC et PC ;)

Faut que je retrouve l'entièreté du module de classe (Collection) que Marc-L m'avait fait …
 
Dernière édition:

Discussions similaires

Réponses
16
Affichages
1 K

Statistiques des forums

Discussions
313 198
Messages
2 096 142
Membres
106 504
dernier inscrit
ngomez