XL 2010 Recherche parties de mots dans une base de données

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

Option Compare Text 'la casse zst ignorée

Private Sub CommandButton1_Click()
Dim crit$, P As Range, L%, lig&, ncol%, i&, a, c As Range, x$, j%
crit = [C2]
L = Len(crit)
lig = 8 '1ère ligne de données
Application.ScreenUpdating = False
Rows(lig & ":" & Rows.Count).Delete 'RAZ
Set P = Feuil1.[B4].CurrentRegion
ncol = P.Columns.Count
If ncol = 1 Then Set P = P.Resize(, 2)
For i = 1 To P.Rows.Count
    a = Application.Transpose(Application.Transpose(P.Rows(i)))
    If InStr(Join(a, Chr(1)), crit) Then
        With Cells(lig, 2).Resize(, ncol)
            .Value = P.Rows(i).Value 'copie les valeurs
            For Each c In .Cells
                x = c
                If InStr(x, crit) Then
                    For j = 1 To Len(x) - L + 1
                        If Mid(x, j, L) = crit Then
                            With c.Characters(j, L)
                                .Font.Color = vbRed 'rouge
                                .Font.Bold = True 'gras
                            End With
                        End If
                    Next j
                End If
            Next c
        End With
        lig = lig + 1
    End If
Next i
End Sub