Sub ExtractPatternsAvecBalise()
' 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
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
' Initialiser le dictionnaire pour les mots en italique
Set italicsWords = 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
' Définir le pattern pour capturer les éléments spécifiques
regex.pattern = "\([^)]*\)|\[[^\]]*\]|""[^""]*""|'[^']*'|«[^»]*»|\*[^*]*\*|_[^_]*_|(\|[^|]*\|)"
' Parcourir chaque cellule dans la colonne A
For i = 1 To Rng.Rows.Count
' Identifier les mots en italique
textItalique = IdentifierItalique(Rng(i), italicsWords)
' Ajouter le texte avec les balises trouvées en italique au texte original
text = Rng.Cells(i, 1).Value & " | " & textItalique
' 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
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 Left(match.Value, 1) = "|" Then
patternType = "Italique"
MotItalique textItalique, text, Rng, i
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
Next match
End If
Next i
' Libérer les objets
Set Sh = Nothing
Set Rng = Nothing
Set regex = Nothing
Set matches = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Erreur dans l'exécution : " & Err.Description, vbExclamation
Set Sh = Nothing
Set Rng = Nothing
Set regex = Nothing
Set matches = Nothing
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 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
End Function
Sub MotItalique(ByVal textItalique As String, ByVal text As String, _
ByRef Rng As Range, ByVal j As Long)
Dim Searsh As Variant
Dim regex As Object
Dim matches As Object
Dim match As Object
' Initialiser RegExp
Set regex = CreateObject("VBScript.RegExp")
regex.IgnoreCase = True
regex.Global = True
Searsh = Split(textItalique, "|")
For i = LBound(Searsh) To UBound(Searsh)
regex.pattern = Trim(Searsh(i))
If regex.Test(text) Then
Set matches = regex.Execute(text)
For Each match In matches
' Mettre en forme les mots trouvés dans la colonne A (rouge et gras)
StartPos = InStr(1, text, match.Value, vbTextCompare)
If StartPos > 0 And Len(match.Value) > 0 Then
With Rng.Cells(j, 1).Characters(StartPos, Len(match.Value)).Font
.Color = RGB(255, 0, 0) ' Rouge
.Bold = True ' Gras
End With
End If
Next match
End If
Next i
End Sub
