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

[Caninge]

Bonjour à tous,

je viens de retrouver ce fichier qui me servait de base de données pour mes papiers (j'ai modifié les textes)
la macro ne fonctionne pas, mais bon j'ai changé l'emplacement des cellules notamment celle de la recherche (C2)
Comment là remettre en activité et aboutir à la recherche d'une partie ou l'ensemble d'un mot.
C'est à dire puiser dans la base de données et écrire le résultat dans la page recherche. Lettres recherchées en rouge et gras.
Je joins un fichier.
Merci d'avance.
CANINGE

 

[wDog66]

Bonjour Caninge

Pourrais-tu nous en dire plus sur le pourquoi de ces colonnes ?
Le tableau dans le code est dimensionné pour 6, dans la BdD il n'y en a que 3 sans compter la colonne B qui contient des lettres !?

A+

 

[Caninge]

Bonjour,

oui il y a moins de colonnes qu'auparavant. Il y en a 4 : B C D E

 

[vgendron]

Hello

le code fait un test sur 5 ou 6 critères en ligne 2
il n'y en a plus qu'un??

pourquoi ne pas simplement utiliser des tables structurées et ajout d'un segment ?

 

[wDog66]

Salut vgendron 😉

Perso, je continue en VBA, mais j'essaie de comprendre l'utilisation du fichier 🤪

@Caninge

Bonjour,

oui il y a moins de colonnes qu'auparavant. Il y en a 4 : B C D E

Oui, ça d'accord, mais ensuite !

On fait la recherche des mot contenant "P" (par exemple)
qu'est-ce que cela doit vous ramener en terme d'information par colonne et pourquoi ?

 

[vgendron]

@wDog66
tel que je comprend le code initial
la ligne 2 contient DES critères
en B: critère pour la colonne 1 du tableau
en C: critère pour la colonne 2 du tableau
etc jusqu'au critère en F2

si UN des critères est vérifié, alors la ligne complète est copiée

critère = like "*MOT*

 

[wDog66]

@wDog66
tel que je comprend le code initial
la ligne 2 contient DES critères
en B: critère pour la colonne 1 du tableau
en C: critère pour la colonne 2 du tableau
etc jusqu'au critère en F2

si UN des critères est vérifié, alors la ligne complète est copiée

critère = like "*MOT*

Re,

"si UN des critères est vérifié, alors la ligne complète est copiée"
C'est bien ca que je ne comprends et dont je veux m'assurer 🤪

 

[Caninge]

bonjour,
je préfère garder la procédure VBA. Bien entendu il faut là modifier puisque j'utilise moins de colonnes.
En fait si j'écris P dans la cellule la procédure recherche toutes les lignes où il y a un P dans la basse de données.
C'est à dire les lignes B C G et s'écrivent les unes au dessous des autres dans la feuille recherche comme dans mon exemple.
Et le P devient rouge

 

[vgendron]

Dans la PJ

dans la feuille Base de données ==> tu tapes une partie de mot dans une des cellules jaunes (ligne 2)
tu valides, le filtre est appliqué
pour défiltrer, il suffit d'effacer le mot

 

[Caninge]

Autre exemple avec RE

 

[laurent950]

Bonsoir @Caninge

vous pouvez écrire se que vous souhaitez faire.
un exemple simple que vous écrivez.
et je traduit en VBA

 

[Caninge]

Bonjour,

dans la cellule C2 j'écris par exemple MO
Je clique sur le bouton Recherche et la procédure recherche et récupère dans la base de données
tous les mots contenant MO. Ensuite ils s'écrivent dans la feuille Recherche.
La recherche se fait sur les 4 Colonnes

 

[laurent950]

Re,

Regex, Recherche paterne simple + Mise en couleur du paterne avec "FormatText".

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

 

[job75]

Bonsoir à tous,

Une solution classique et assez simple :

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

A+

 

[job75]

Pour tester les durées d'exécution j'ai copié le tableau source B4:E10 sur 70 000 lignes :

- macro du post #13 => 21,6 secondes

- macro du post #14 => 9,5 secondes.

Bonne nuit.