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

[kalem]

Bonjour,
A nouveau besoin de vos lumières !
Je tape des appréciations pour des élèves. Je souhaiterais que lorsque j'indique par exemple, "intro à revoir", Excel détecte le mot clé "intro" et indique dans une zone "conseils" un rappel du cours sur la méthode de l'introduction.
J'ai donc ma feuille "Relevé" qui contient les appréciations, et ma feuille "Conseils", avec en A, les mots-clés, et en B, le conseil lui-même.
J'ai essayé ceci : =SI(NB.SI(B5:G19;"*Conseils!A:A*");"B:B";""), mais ça ne fonctionne pas, j'ai dû faire erreur.

De toute façon, je crois par ailleurs qu'il faut passer par une macro pour qu'Excel revienne à la ligne et indique un nouveau conseil dès qu'un mot clé est détecté.

Si vous avez une idée... je suis preneur ! Merci d'avance.

 

[job75]

Re,

Dernière solution, par macros évènementielles :

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

Elles doivent être placées dans le code de la feuille "Relevé" (clic droit sur l'onglet et Visualiser le code).

C'est la meilleure solution car il n'y a plus aucune opération manuelle sur le tableau des résultats.

Fichier joint.

A+

 

[kalem]

Ah, je n'y parviens pas ... Si cela ne vous dérange pas, je vous envoie mon fichier en mp.

 

[job75]

Re,

OK j'ai vu votre fichier, il y a 2 erreurs (graves) dans le code de votre feuille "Releve" :

- Option Explicit doit être placé tout en haut du code

- il ne peut pas exister 2 macros Worksheet_Change, il en faut une seule avec le code complété ainsi :

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

A+

 

[kalem]

D'accord, merci beaucoup, Job75, pour cette réponse rapide !

 

[job75]

Re,

Et il y a une 3ème erreur (vous pourriez quand même faire quelques efforts).

Dans la macro Worksheet_Activate remplacez Feuil2 pat Feuil9 : c'est votre feuille "Conseils".

A+

 

[job75]

Bonjour kalem, le forum,

J'ai finalement adapté mon code du post #16 à votre fichier (ci-joint) :

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

Plusieurs remarques :

- curieusement Application.Transpose ne fonctionne pas sur ce fichier, j'ai dû faire une boucle pour transposer

- pour masquer le quadrillage inutile de colorer les cellules en blanc, utiliser la commande de l'onglet MISE EN PAGE

- je n'ai pas Outlook, dans VBA (Outils-Références) j'ai dû décocher "Microsoft Outlook 16.0 Object Library".

Bonne journée.

 

[job75]

Re,

Pour restituer les conseils/rappels en colonnes B et F c'est un peu plus compliqué :

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

J'ai remplacé la méthode AutoFill par la méthode Copy car elle beuguait s'il n'y avait qu'une ligne.

Fichier (2).

A+

 

[kalem]

Bonjour à tous,
Merci job75, c'est parfait ainsi. J'ai un peu appris Excel au fil de tests et bidouillages divers, mais là, les soucis que vous évoquez me dépassent un peu... Quoi qu'il en soit... ça fonctionne ! C'est vraiment formidable.
Encore merci !
Bonne journée.