Microsoft 365 Code VBA Recherche par mots clés

[looky62]

Hello la communauté,

Je suis bloqué sur mon codage, qui peut m'éclairer

En feuil2 colonne A, ligne avec du texte, je souhaite insérer en colonne B les mots recherchés qui se trouve dans la feuil1 a partir de A2, si les mots recherches à partir de la colonne B à partir de B2, alors mettre le mot qui correspond a la colonne A, exemple , si en feuil1 se trouve un mot en B4 dans la feuil2 alors mettre le mot correspondant à la ligne en A4 et ainsi de suite, de base ma macro ne trouve pas les mots, pourtant je respecte bien l'orthographe d'où vient le pb?

Serait il possible d'ajouter plusieurs mots clés a chercher par exemple, si différente orthographe, entre: résiliation, resiliation, résil, à résilier, ce qui ramenerai en colonne B de la feuil2 le mot Résiliation à faire!

Sub RechercherMots()

' Déclaration des variables
Dim Feuil1 As Worksheet
Dim Feuil2 As Worksheet
Dim DernLigne1 As Long
Dim DernLigne2 As Long
Dim i As Long
Dim j As Long
Dim MotRecherche As String

' Récupération des références aux feuilles de calcul
Set Feuil1 = ThisWorkbook.Worksheets("Feuil1")
Set Feuil2 = ThisWorkbook.Worksheets("Feuil2")

' Trouver la dernière ligne contenant des données dans chaque feuille
DernLigne1 = Feuil1.Cells(Rows.Count, "A").End(xlUp).Row
DernLigne2 = Feuil2.Cells(Rows.Count, "A").End(xlUp).Row

' Parcourir chaque ligne de la colonne B de la feuille 2
For i = 2 To DernLigne2
' Récupérer le mot à rechercher dans la colonne B de la feuille 2
MotRecherche = Feuil2.Cells(i, "B").Value
' Parcourir chaque ligne de la colonne A de la feuille 1
For j = 2 To DernLigne1
' Vérifier si le mot à rechercher se trouve dans la colonne B de la feuille 1
If Feuil1.Cells(j, "B").Value = MotRecherche Then
' Insérer le mot correspondant dans la colonne B de la feuille 2
Feuil2.Cells(i, "A").Value = Feuil1.Cells(j, "A").Value
' Sortir de la boucle de recherche dans la feuille 1 pour passer au mot suivant
Exit For
End If
Next j
Next i

End Sub

 

[job75]

Notez qu'en colonne A de la 1ère feuille il pourrait y avoir des lignes chevauchant plusieurs zones filtrées.

Avec la macro du post #13 les textes en colonne B sont ceux du dernier filtrage, les précédents sont écrasés.

Dans ce fichier (2) j'ai mis 2 chevauchements en A3 et A5 et cette nouvelle macro :

Private Sub Worksheet_Activate()
Dim P As Range, titre$, i&, critere
Set P = [A1].CurrentRegion
titre = P(1, 2)
Application.ScreenUpdating = False
P.Columns(2).ClearContents 'RAZ colonne B
With Sheets("Feuil1").[A1].CurrentRegion 'feuille des critères
    For i = 2 To .Rows.Count
        critere = Split(Application.Trim(.Cells(i, 2)), ", ") 'attention au séparateur
        If UBound(critere) >= 0 Then
            ThisWorkbook.Names.Add "Crit", critere 'nom défini
            [H2] = "=SUMPRODUCT(N(ISNUMBER(SEARCH(Crit,A2))))" 'critere de filtrage
            P.Columns(3) = P.Columns(2).Value 'copie toute la colonne B
            P.AdvancedFilter xlFilterInPlace, [H1:H2] 'filtre avancé
            P.Columns(3).SpecialCells(xlCellTypeVisible) = "=IF(RC[-1]="""","""",RC[-1]&"" - "")&""" & .Cells(i, 1) & """" 'formule
            If FilterMode Then ShowAllData 'RAZ
            P.Columns(3) = P.Columns(3).Value 'supprime les formules
            P.Columns(2) = P.Columns(3).Value 'copie les textes concaténés
        End If
    Next
End With
P.Columns(3).ClearContents 'RAZ colonne C
[H2] = ""
P(1, 2) = titre
End Sub

Les textes des filtrages sont maintenant concaténés en colonne B de la 1ère feuille.

 

[job75]

Bien que la 2ème macro soit plus complexe les durées d'exécution restent du même ordre.

Environ 2/100èmes de seconde chez moi.