Microsoft 365 Code VBA Recherche par mots clés

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

Private Sub Worksheet_Change(ByVal Target As Range)
Dim critere
critere = Split(Application.Trim([C1]), ", ") 'attention au séparateur
If UBound(critere) = -1 Then ShowAllData: Exit Sub
Application.EnableEvents = False 'désactive les évènements
ThisWorkbook.Names.Add "Crit", critere 'nom défini
[H2] = "=SUMPRODUCT(N(ISNUMBER(SEARCH(Crit,A2))))" 'critere de filtrage
[A1].CurrentRegion.AdvancedFilter xlFilterInPlace, [H1:H2] 'filtre avancé
[H2] = ""
Application.EnableEvents = True 'réactive les évènements
End Sub

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
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.AdvancedFilter xlFilterInPlace, [H1:H2] 'filtre avancé
            P.Columns(2).SpecialCells(xlCellTypeVisible) = .Cells(i, 1) 'remplissage
        End If
    Next
End With
If FilterMode Then ShowAllData 'RAZ
[H2] = ""
P(1, 2) = titre
End Sub