Sub ExtractPatternsAvecBalise()
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
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
Set italicsWords = CreateObject("Scripting.Dictionary")
Set Sh = Worksheets("a")
Set Rng = Sh.Range(Sh.Cells(2, 1), Sh.Cells(Sh.Rows.Count, 1).End(xlUp))
Sh.Range(Sh.Cells(2, 4), Sh.Cells(Sh.Rows.Count, 4)).ClearContents
Sh.Range(Sh.Cells(2, 5), Sh.Cells(Sh.Rows.Count, 5)).ClearContents
outputRow = 2
Set regex = CreateObject("VBScript.RegExp")
regex.IgnoreCase = True
regex.Global = True
regex.pattern = "\([^)]*\)|\[[^\]]*\]|""[^""]*""|'[^']*'|«[^»]*»|\*[^*]*\*|_[^_]*_|(\|[^|]*\|)"
For i = 1 To Rng.Rows.Count
textItalique = IdentifierItalique(Rng(i), italicsWords)
text = Rng.Cells(i, 1).Value & " | " & textItalique
If regex.Test(text) Then
Set matches = regex.Execute(text)
For Each match In matches
Sh.Cells(outputRow, 4).Value = match.Value
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
Sh.Cells(outputRow, 5).Value = patternType
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)
.Bold = True
End With
End If
outputRow = outputRow + 1
Next match
End If
Next i
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
msg = ""
For i = 1 To Len(cell.Value)
If cell.Characters(i, 1).Font.Italic = True Then
word = Mid(cell.Value, i, 1)
msg = msg & word
If cell.Characters(i + 1, 1).Font.Italic <> True Then
msgTemp = Application.Trim(Split(msg, "|")(UBound(Split(msg, "|"))))
If Not italicsWords.exists(msgTemp) Then
italicsWords.Add msgTemp, True
msg = msg & " | "
msgTemp = Empty
End If
End If
End If
Next i
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
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
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)
.Bold = True
End With
End If
Next match
End If
Next i
End Sub
