Sub es()
' ExtractPatternsOptimized
Dim BD As Worksheet, ws As Worksheet
Dim rng As Range, cell As Range
Dim regex As Object, matches As Object, match As Object
Dim arrData As Variant
Dim outputRow As Long
Dim startPos As Long
Dim i As Long, j As Long
Dim flag As Boolean
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
' Initialisation des feuilles de travail
Set BD = Worksheets("Base de données")
Set ws = Worksheets("Recherche")
' Plage à analyser
Set rng = BD.Range(BD.Cells(4, 2), BD.Cells(BD.Rows.Count, 5).End(xlUp))
' Initialisation de l'expression régulière
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = True
regex.Pattern = ws.Cells(2, 3).Value2 ' Modèle à rechercher
' Nettoyage des résultats précédents
ws.Range("B8:E" & ws.Rows.Count).Clear
outputRow = 8
' Charger les données de la plage dans un tableau pour améliorer la performance
arrData = rng.Value
' Parcours des lignes et des colonnes dans le tableau
For i = 1 To UBound(arrData, 1) ' Parcours des lignes
For j = 1 To UBound(arrData, 2) ' Parcours des colonnes
' Vérifier si une correspondance est trouvée
If regex.Test(arrData(i, j)) Then
' Ajouter la valeur à la feuille de résultats
ws.Cells(outputRow, j + 1).Value = arrData(i, j)
' Appliquer le formatage si une correspondance est trouvée
startPos = InStr(1, arrData(i, j), regex.Pattern, vbTextCompare)
If startPos > 0 Then FormatText ws.Cells(outputRow, j + 1), startPos, Len(regex.Pattern)
' Test (Si le patrene a était trouvé au moin une fois)
flag = True
Else
' Ajouter la valeur à la feuille de résultats
ws.Cells(outputRow, j + 1).Value = arrData(i, j)
End If
Next j
'
' Mise en forme et recopie des lignes dont le paterne a était trouvé.
If flag = False Then: ws.Cells(outputRow, 2).Resize(, 4).Clear: Else: outputRow = outputRow + 1: flag = False
Next i
'
Cleanup:
' Libération des objets
Set ws = Nothing
Set BD = Nothing
Set rng = Nothing
Set regex = Nothing
Application.ScreenUpdating = True
Exit Sub
'
ErrorHandler:
' Gestion des erreurs
MsgBox "Erreur : " & Err.Description, vbExclamation
Resume Cleanup
End Sub
'
Private Sub FormatText(ByVal cell As Range, ByVal startPos As Long, ByVal length As Long)
' Appliquer le formatage à la portion de texte correspondante
With cell.Characters(startPos, length).Font
.Color = RGB(255, 0, 0) ' Rouge
.Bold = True
End With
End Sub
