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