metre en gras une liste de mots

stash

XLDnaute Nouveau
Bonjour,

J'explique ma situation.
J'essaie d'automatiser la création et l'édition des Fiches techniques de nos produits...
J'ai donc le classeur en Pj, avec 3 onglets:
_liste produit à partir de laquelle je souhaite faire une macro pur éditer au format word les ft(je m'en suis pas encore occuper^^)
_une base de données étiquettes avec les listes d'ingrédients;
_et le modèle Ft , feuille sur laquelle je bosse en ce moment....et je galère!!!


J'ai réussi à faire ce code en m'inspirant un peu partout.
Seulement, il me faut lister tout les allergènes dans les 3 langues, je vais avoir un code assez lourds....mais ça peut encore le faire.
Par contre, chaque allergène n'est mis en gras qu'une fois....et je voudrai qu'ils tous soient mis en gras (si le mot lait est 3 fois dans la cellule=> 3 fois en gras)
Voici mon code (relié au bouton "allergène")


Code:
Sub allergène()
mot = " ble"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "lait"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "oeuf"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "oeufs"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "beurre"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "soja"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "sulfites"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "SO2"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "weat"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "milk"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "egg"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "eggs"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "soya"
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
mot = "sulphites"
  For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
  mot = "leche"
  For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
  mot = "huevos"
  For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
  mot = "mantequilla"
  For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
  mot = "trigo"
  For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
End Sub

Après, si vous avez une solution plus simple, comme utiliser la liste en colonne A....je suis preneur...je demande qu'à apprendre.


Merci par avance de votre aide!!!!!!

Cordialement.
 

Pièces jointes

  • bdd FT CDD.xlsm
    120.5 KB · Affichages: 54
  • bdd FT CDD.xlsm
    120.5 KB · Affichages: 50
  • bdd FT CDD.xlsm
    120.5 KB · Affichages: 54

Roland_M

XLDnaute Barbatruc
Re : metre en gras une liste de mots

bonjour,

ici tu peux faire comme ceci:

Code:
Sub allergène()
Dim Tablo As Variant
Tablo = Array("ble", "blé", "...") ' <<<<< ici la suite de ta liste
For I = LBound(Tablo) To UBound(Tablo): Findallergène Tablo(I): Next
End Sub

Sub Findallergène(Mot As String)
Dim C As Range
For Each C In Range("B2:B" & [B65000].End(xlUp).Row)
  P = InStr(UCase(C), UCase(Mot))
  If P > 0 Then C.Characters(Start:=P, Length:=Len(Mot)).Font.Bold = True
Next
End Sub
 

phlaurent55

Nous a quittés en 2020
Repose en paix
Re : metre en gras une liste de mots

Bonjour stash,

en remplaçant tout le code par celui-ci
Code:
Sub allergène()
For Each cellule In Range("A2:A14") ' à adapter
For Each c In Range("B2:B" & [B65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(cellule))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(cellule)).Font.Bold = True
  Next c
Next cellule
End Sub
à+
Philippe

Edit: Bonjour Roland
 

stash

XLDnaute Nouveau
Re : metre en gras une liste de mots

Merci pour vos retour phlaurent55 et Roland_M.

mais cela ne fonctionne pas comme prévu....

phlaurent55, ta solution me met en gras tout le contenu des cellule qui comporte les mots cibles....

Roland_, "erreur de compilation: type d'argument ByRef incompatible"
"Sub allergène()" est surligné en jaune et tablo est pré-sélectionné...

lol....je suis novice, donc il se peut que l'erreur soit mienne^^

Merci de vos retours.
 

stash

XLDnaute Nouveau
Re : metre en gras une liste de mots

Merci à vous deux :)
Philippe, je suis désolé, c'est parce que j'adaptais une plage trop grande avec des cellules vides pour la liste des allergènes^^

Par contre, même avec vos solution, un seul exemplaire de chaque mot se met en gras...("BLE" qui apparait souvent, n'est en gras qu'une fois...
exemple tiré d'une FT:
farine de BLE, sucre, huile végétale, sirop de sucre, poudre à lever chimique (carbonate acide de sodium), farine de SOJA, sel), farine de BLE(pas en gras?), BEURRE, ...
le premier Ble est mis en gras, pas le second...

Merci de votre aide en tout cas^^
 

Roland_M

XLDnaute Barbatruc
Re : metre en gras une liste de mots

re


voir comme ceci c'est ok ! vérifié !
effectivement il fallait boucler sur la chaine !

Code:
Sub Allergène()
 Dim Tablo As Variant
 Tablo = Array("ble", "blé", "lait") ' <<<<< ici la suite de ta liste
 For I = LBound(Tablo) To UBound(Tablo): FindAllergène Tablo(I): Next
 End Sub

 Sub FindAllergène(Mot As Variant)
 Dim C As Range
 For Each C In Range("B2:B" & [B65000].End(xlUp).Row)
   V$ = UCase(C.Value)
   I1 = InStr(V$, UCase(Mot))
   While I1 > 0
      C.Characters(Start:=I1, Length:=Len(Mot)).Font.Bold = True
      I1 = InStr(I1 + 1, V$, UCase(Mot))
   Wend
 Next
 End Sub
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 726
Messages
2 081 955
Membres
101 852
dernier inscrit
dthi16088