RÉSOLU - Afficher un texte dans une cellule en fonction d'un mot-clé

Private Sub Worksheet_Activate()
Dim P As Range, dest As Range, t, d As Object, i&
Set P = [A5:G19] 'plage à adapter
Set dest = [A24:F24] '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
t = Feuil2.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  If Application.CountIf(P, "*" & t(i, 1) & "*") Then d(t(i, 2)) = ""
Next
dest = ""
dest.Offset(1).Resize(Rows.Count - dest.Row).Delete xlUp
If d.Count Then
  dest.AutoFill dest.Resize(d.Count), xlFillFormats
  dest(1).Resize(d.Count) = Application.Transpose(d.keys)
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance cette macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1")) Is Nothing Then _
   Range("5:40").EntireRow.AutoFit ' commande pour ajuster automatiquement la hauteur des lignes 5 a 40
Worksheet_Activate 'lance cette macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance cette macro
Rows("5:40").AutoFit 'ajustement des hauteurs de lignes
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, dest As Range, t, d As Object, i&, a
Set P = [B5:F15] 'plage à adapter
Set dest = [B17] '1ère cellule de destination, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
t = Feuil9.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  If Application.CountIf(P, "*" & t(i, 1) & "*") Then d(t(i, 2)) = ""
Next
dest = ""
dest.Offset(1).Resize(Rows.Count - dest.Row).Delete xlUp
If d.Count Then
  a = d.keys: ReDim t(1 To d.Count, 1 To 1)
  For i = 0 To UBound(a)
    t(i + 1, 1) = a(i) 'transposition
  Next
  dest.AutoFill dest.Resize(d.Count), xlFillFormats
  dest.Resize(d.Count) = t
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance cette macro
Rows("5:40").AutoFit 'ajustement des hauteurs de lignes
End Sub

Private Sub Worksheet_Activate()
Dim P As Range, dest As Range, t, d As Object, i&, a, h&
Set P = [B5:F15] 'plage à adapter
Set dest = [A17:G17] '1ère ligne de destination, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
t = Feuil9.[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  If Application.CountIf(P, "*" & t(i, 1) & "*") Then d(t(i, 2)) = ""
Next
dest = ""
dest.Offset(1).Resize(Rows.Count - dest.Row).Delete xlUp
If d.Count Then
  a = d.keys
  h = Application.Ceiling(d.Count / 2, 1) 'fonction PLAFOND
  ReDim t(1 To h, 1 To 5)
  For i = 0 To UBound(a)
    t(Int(i / 2) + 1, IIf(i Mod 2, 5, 1)) = a(i)
  Next
  dest.Copy dest.Resize(h) 'pour copier les formats
  dest(1, 2).Resize(h, 5) = t 'colonnes B à F
End If
Application.EnableEvents = True
End Sub