Sub ExtractPatternsAvecBaliseSansDoublons()
' Recherche dans la colonne A pour détecter :
' - Parenthèses : ( ... )
' - Crochets : [ ... ]
' - Guillemets : " ... ", ' ... ', « ... »
' - Italiques : ...
' Résultats :
' - Colonne D : Mot trouvé entre les balises
' - Colonne E : Type de balise trouvé (ex. Parenthèses, Italique, etc.)
' Le texte trouvé est mis en rouge et gras dans la colonne A.
Dim Sh As Worksheet
Dim Rng As Range
Dim i As Long
Dim textItalique As String
Dim text As String
Dim regex As Object
Dim matches As Object
Dim match As Object
Dim outputRow As Long
Dim patternType As String
Dim StartPos As Long
Dim italicsWords As Object ' Dictionnaire pour les mots en italique
Dim arrKeys As Variant
Dim j As Long
Dim keysString As String
' Pour Chaques cellules / Gestions des doublons
Dim italicsWordsDoublon As Object ' Dictionnaire pour les mots en italique
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
' Initialiser le dictionnaire pour les mots en italique aux Global
Set italicsWords = CreateObject("Scripting.Dictionary")
' Initialiser le dictionnaire pour les mots en italique Doublons -->> Déjà connus
Set italicsWordsDoublon = CreateObject("Scripting.Dictionary")
' Définir la feuille de calcul et la plage
Set Sh = Worksheets("a")
Set Rng = Sh.Range(Sh.Cells(2, 1), Sh.Cells(Sh.Rows.Count, 1).End(xlUp)) ' Commence à la ligne 2
' Effacer les anciennes données dans les colonnes D et E
Sh.Range(Sh.Cells(2, 4), Sh.Cells(Sh.Rows.Count, 4)).ClearContents ' Colonne D
Sh.Range(Sh.Cells(2, 5), Sh.Cells(Sh.Rows.Count, 5)).ClearContents ' Colonne E
' Initialiser la ligne de départ pour les résultats
outputRow = 2
' Initialiser RegExp
Set regex = CreateObject("VBScript.RegExp")
regex.IgnoreCase = True
regex.Global = True
' Parcourir chaque cellule dans la colonne A
For i = 2 To Rng.Rows.Count
' Identifier les mots en italique
textItalique = IdentifierItalique(Rng(i), italicsWords)
' Récupération des clés dans un tableau
arrKeys = italicsWords.Keys ' Tableau des clés
' Nettoyage des espaces autour des clés
For j = LBound(arrKeys) To UBound(arrKeys)
arrKeys(j) = Trim(arrKeys(j)) ' Supprime les espaces
arrKeys(j) = Replace(arrKeys(j), Chr(160), "") ' Supprime les espaces insécables
Next j
' Conversion des clés en chaîne de caractères (séparées par "|")
keysString = Join(arrKeys, "|") ' Exemple : "Nom|Ville|Pays"
Erase arrKeys
' Configuration de la regex
regex.pattern = "\([^)]*\)|\[[^\]]*\]|""[^""]*""|'[^']*'|«[^»]*»|\*[^*]*\*|_[^_]*_|(\|[^|]*\|)|" & keysString
' Ajouter le texte avec les balises trouvées en italique au texte original
text = Rng.Cells(i, 1).Value
' Exécuter la recherche avec RegExp
If regex.Test(text) Then
Set matches = regex.Execute(text)
' Ajouter chaque correspondance dans la colonne D et le type en colonne E
For Each match In matches
If Not italicsWordsDoublon.exists(match.Value) Then
Sh.Cells(outputRow, 4).Value = match.Value ' Colonne D : correspondance trouvée
' Déterminer le type de pattern trouvé
If Left(match.Value, 1) = "(" And Right(match.Value, 1) = ")" Then
patternType = "Parenthèses"
ElseIf Left(match.Value, 1) = "[" And Right(match.Value, 1) = "]" Then
patternType = "Crochets"
ElseIf Left(match.Value, 1) = """" And Right(match.Value, 1) = """" Then
patternType = "Guillemets doubles"
ElseIf Left(match.Value, 1) = "'" And Right(match.Value, 1) = "'" Then
patternType = "Guillemets simples"
ElseIf Left(match.Value, 1) = "«" And Right(match.Value, 1) = "»" Then
patternType = "Guillemets français"
ElseIf Rng.Cells(i, 1).Characters(match.FirstIndex + 1, 1).Font.Italic = True Then
patternType = "Italique"
Else
patternType = "Inconnu"
End If
' Écrire le type dans la colonne E
Sh.Cells(outputRow, 5).Value = patternType ' Colonne E : type de pattern
' Mettre en forme les mots trouvés dans la colonne A (rouge et gras)
StartPos = InStr(1, text, match.Value, vbTextCompare)
If StartPos > 0 Then
With Rng.Cells(i, 1).Characters(StartPos, Len(match.Value)).Font
.Color = RGB(255, 0, 0) ' Rouge
.Bold = True ' Gras
End With
End If
' Passer à la ligne suivante
outputRow = outputRow + 1
' Remplir le dictonaire
italicsWordsDoublon.Add match.Value, True
Else
' Mettre en forme les mots trouvés dans la colonne A (rouge et gras)
StartPos = InStr(1, text, match.Value, vbTextCompare)
If StartPos > 0 Then
With Rng.Cells(i, 1).Characters(StartPos, Len(match.Value)).Font
.Color = RGB(255, 0, 0) ' Rouge
.Bold = True ' Gras
End With
End If
End If
Next match
End If
Next i
' Libération des objets
On Error Resume Next ' Pour éviter les erreurs si l'objet n'existe pas
Set Sh = Nothing
Set Rng = Nothing
Set regex = Nothing
Set matches = Nothing
Set match = Nothing
Set italicsWords = Nothing
Set italicsWordsDoublon = Nothing
On Error GoTo 0 ' Réactiver la gestion normale des erreurs
' Réinitialisation des variables simples
i = 0
textItalique = vbNullString
text = vbNullString
outputRow = 0
patternType = vbNullString
StartPos = 0
' Réinitialisation des tableaux et autres variables spécifiques
arrKeys = Empty
keysString = vbNullString
j = 0
' Confirmation de déchargement (facultatif)
Debug.Print "Toutes les variables ont été déchargées.", vbInformation, "Déchargement terminé"
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Erreur dans l'exécution : " & Err.Description, vbExclamation
' Libération des objets
On Error Resume Next ' Pour éviter les erreurs si l'objet n'existe pas
Set Sh = Nothing
Set Rng = Nothing
Set regex = Nothing
Set matches = Nothing
Set match = Nothing
Set italicsWords = Nothing
Set italicsWordsDoublon = Nothing
On Error GoTo 0 ' Réactiver la gestion normale des erreurs
' Réinitialisation des variables simples
i = 0
textItalique = vbNullString
text = vbNullString
outputRow = 0
patternType = vbNullString
StartPos = 0
' Réinitialisation des tableaux et autres variables spécifiques
arrKeys = Empty
keysString = vbNullString
j = 0
' Confirmation de déchargement (facultatif)
Debug.Print "Toutes les variables ont été déchargées.", vbInformation, "Déchargement terminé"
Application.ScreenUpdating = True
End Sub
Function IdentifierItalique(ByRef cell As Range, ByRef italicsWords As Object) As String
Dim i As Integer
Dim word As String
Dim msg As String
Dim msgTemp As String
' Initialiser la chaîne de message pour les mots en italique
msg = ""
' Vérifie chaque caractère dans la cellule
For i = 1 To Len(cell.Value)
' Si le caractère est en italique, l'ajouter à la chaîne de message
If cell.Characters(i, 1).Font.Italic = True Then
word = Mid(cell.Value, i, 1)
msg = msg & word
' Ajouter un séparateur "|" après chaque mot en italique
If cell.Characters(i + 1, 1).Font.Italic <> True Then
msgTemp = Application.Trim(Split(msg, "|")(UBound(Split(msg, "|"))))
If Not italicsWords.exists(msgTemp) Then
' Ajouter le mot au dictionnaire
italicsWords.Add Trim(msgTemp), True
msg = msg & " | "
msgTemp = Empty
End If
End If
End If
Next i
' Retourner le message des mots en italique
If Len(msg) > 0 Then
'Debug.Print "Mots en italique trouvés dans la cellule " & cell.Address & ": " & msg
IdentifierItalique = msg
End If
' Réinitialisation des variables simples
i = 0
word = vbNullString
msg = vbNullString
msgTemp = vbNullString
' Confirmation de déchargement (facultatif)
Debug.Print "Les variables supplémentaires ont été déchargées.", vbInformation, "Déchargement terminé"
End Function
