XL 2021 Macro dans Macro

[Constantin]

Bonjour à tous,
Dans le fichier joint, je m' intéresse surtout à deux macros :
- Grouper3()
- IdentifierPointsCollecte
Vous avez été nombreux à m'aider à réaliser cet utilitaire et je remercie ces contributeurs...

La macro Grouper3() permet de sélectionner les cellules de localisation qui m’intéressent dans la feuille "Plan"
La macro IdentifierPointsCollecte réalise le formatage des cellules du Plan en fonction des produits choisis dans "Sélection".
Pour l'heure, la sélection des cellules à formater s'effectue au moyen d'un "Range" qui ne contient pas moins de 20 tables du fait qu'une table ne peut contenir qu'un nombre fini d'éléments.

Je voudrais m'exonérer de ce "Range" (donc le remplacer par autre chose) en utilisant la sélection telle qu'on peut l'obtenir avec la macro Grouper3(). En gros, cela reviendrait à activer Grouper3() pour remplacer le contenu de ce "Range"... Je ne sais pas si c'est possible. J'essaye depuis plusieurs jours et je n'arrive à rien.
Si vous avez une idée...
Bien cordialement,
Pierre

 

[Constantin]

Les "Points de collecte sont placés dans la feuille "Sélection" en colonne J&K. (d'où les boutons "Afficher et Cacher J&K"

La macro fonctionne à la condition que la colonne J soit remplie avec les cellules de la colonne D de la feuille "Listes". Je sais ce que vous allez me dire, c'est une usine à gaz mon bazar. On aurait tout aussi bien pu aller chercher les références de localisation dans cette feuille, mais là, j'ai un peu peur de ne faire que des bêtises.
La colonne K (Nb) indique si une des références (Critère) a été sélectionnée dans t-ListeCourses. T-Points Collecte récupère ces infos dans Listes... (si j'ai compris...).
Je regarde pour le g au lieu du q (Post#15)

 

[Constantin]

Pas de g à la place des q semble t-il...

 

[Dranreb]

Pourquoi dites vous "à la place des q" ? Vérifiez seulement le nom du style et renommez le s'il contient un g au lieu du q. Chez moi la procédure en #13 fonctionne. Elle surligne les étiquettes mentionnées en Localisation.

 

[Constantin]

Dites-moi si je suis irrécupérable... 313 = Post#13 ?
C'est bien la macro que j'ai copiée dans mon code d'IdentifierPointsCollecte.
Je ne comprends pas ce qui ne va pas chez moi, je me permets de vous soumettre mon fichier ?
Bien cordialement,

 

[Dranreb]

Je trouve que la Sub IdentifierPointsCollecte marche bien dans votre dernier classeur du poste #19.
Ah, non, excuses, il manque MergeArea :

If Err = 0 Then Cel.MergeArea.Style = "EtqSurlgn"

Dans la collection seules son notées les cellules non vide de ce style, pas leurs MergeArea.

 

[Dranreb]

Remarquez: il serait possible de sélectionner les étiquette surlignées afin de pouvoir les parcourir par touche Tab :

Sub IdentifierPointsCollecte()
   Dim ClnEtq As Collection, Cel As Range, RngA As Range, L As Long, RngSel As Range
   Set ClnEtq = New Collection
   For Each Cel In Feuil5.UsedRange
'      If VarType(Cel.Value) = vbString And IsNumeric(Mid$(Cel.Value, 2)) Then Cel.MergeArea.Style = "EtqNorm"
      If Cel.Style Like "Etq*" And Not IsEmpty(Cel.Value) Then
         ClnEtq.Add Item:=Cel, Key:=Cel.Value
         Cel.MergeArea.Style = "EtqNorm"
         End If
      Next Cel
   T = [t_ListeCourses[[CHOIX (x)]:[Localisation]]].Value
   For L = 1 To UBound(T, 1)
      If Not IsEmpty(T(L, 1)) Then
         On Error Resume Next
         Set Cel = ClnEtq(T(L, 2))
         If Err = 0 Then Cel.MergeArea.Style = "EtqSurlgn": If RngSel Is Nothing _
            Then Set RngSel = Cel.MergeArea Else Set RngSel = Union(RngSel, Cel.MergeArea)
         On Error GoTo 0
         End If
      Next L
   Application.Goto RngSel
'   For Each RngA In [t_ListeCourses[Localisation]].SpecialCells(xlCellTypeVisible).Areas
'      If RngA.Rows.Count = 1 Then
'         ReDim T(1 To 1, 1 To 1): T(1, 1) = RngA.Value
'      Else: T = RngA.Value: End If
'      For L = 1 To UBound(T, 1)
'         If Not IsEmpty(T(L, 1)) Then
'            On Error Resume Next
'            Set Cel = ClnEtq(T(L, 1))
'            If Err = 0 Then Cel.MergeArea.Style = "EtqSurlgn"
'            On Error GoTo 0
'            End If
'         Next L, RngA
   End Sub

 

[Constantin]

Alors là, c'est parfait !

Pour la remarque en utilisant Tab, je crois que c'est inutile. La Macro Eléments (Bouton "Eléments trouvés" de la feuille "Plan") me fait l'inventaire des éventuels oublis de correspondance entre Listes et Plan. L'oubli du MergeArea vient de la macro envoyée dans le post#12. Je ne l'aurai pas trouvé tout seul...
Mille mercis pour aide précieuse (comme d'habitude !).
Je n'ai plus qu'à enrichir ma version finale (j'ai ajouté une dizaine de points de collecte) sans passer par les tables !!! Et en plus, ça fonctionne bien plus vite !
You know what ? I'm happy !

Bien cordialement,
Pierre

 

[Constantin]

Remarquez: il serait possible de sélectionner les étiquette surlignées afin de pouvoir les parcourir par touche Tab :

Sub IdentifierPointsCollecte()
   Dim ClnEtq As Collection, Cel As Range, RngA As Range, L As Long, RngSel As Range
   Set ClnEtq = New Collection
   For Each Cel In Feuil5.UsedRange
'      If VarType(Cel.Value) = vbString And IsNumeric(Mid$(Cel.Value, 2)) Then Cel.MergeArea.Style = "EtqNorm"
      If Cel.Style Like "Etq*" And Not IsEmpty(Cel.Value) Then
         ClnEtq.Add Item:=Cel, Key:=Cel.Value
         Cel.MergeArea.Style = "EtqNorm"
         End If
      Next Cel
   T = [t_ListeCourses[[CHOIX (x)]:[Localisation]]].Value
   For L = 1 To UBound(T, 1)
      If Not IsEmpty(T(L, 1)) Then
         On Error Resume Next
         Set Cel = ClnEtq(T(L, 2))
         If Err = 0 Then Cel.MergeArea.Style = "EtqSurlgn": If RngSel Is Nothing _
            Then Set RngSel = Cel.MergeArea Else Set RngSel = Union(RngSel, Cel.MergeArea)
         On Error GoTo 0
         End If
      Next L
   Application.Goto RngSel
'   For Each RngA In [t_ListeCourses[Localisation]].SpecialCells(xlCellTypeVisible).Areas
'      If RngA.Rows.Count = 1 Then
'         ReDim T(1 To 1, 1 To 1): T(1, 1) = RngA.Value
'      Else: T = RngA.Value: End If
'      For L = 1 To UBound(T, 1)
'         If Not IsEmpty(T(L, 1)) Then
'            On Error Resume Next
'            Set Cel = ClnEtq(T(L, 1))
'            If Err = 0 Then Cel.MergeArea.Style = "EtqSurlgn"
'            On Error GoTo 0
'            End If
'         Next L, RngA
   End Sub

Juste un petit bug...
La macro fonctionne parfaitement lorsque toutes les cellules du Plan sont en style EtqNorm. En revanche, si je veux supprimer une ou plusieurs quantités (Retour arrière sur les cellules de Q/P/V) les anciennes sélections (donc surlignées) ne reviennent pas en style normal.

 

[Dranreb]

Non, pour supprimer une étiquette il faut lui mettre le style Normal manuellement, ou y propager une cellule vide voisine pour écraser le style commençant par "Etq".

 

[Constantin]

Bonsoir Draneb,
J'ai fait évidemment quelques essais (de mon niveau):
- je pars d'un fichier vierge (non rempli)
- Via la macro Eléments, les cellules concernées se mettent en sélection.
- Je sélectionne le style de ces cellules en sélectionnant style 'EtqNorm". Les cellules surlignées redeviennent "normales".
- Je retourne dans "Sélection", j'active la macro "Leclerc". Les choix effectués s'affichent correctement dans le plan.
- Je neutralise les quantités (les "X" disparaissent), j'active à nouveau la macro Leclerc et sur le plan, les cellules préalablement sélectionnées puis désélectionnées restent en surligné.
- J'active la macro du Plan (Eléments trouvés) qui me permet de sélectionner les cellules du type A050 etc...
- Je repasse en style 'EtqNorm". Les surlignages disparaissent
- Je retourne dans sélection recommence la manœuvre sur des Choix (qui sont vides) et le Plan affiche toujours les sélections en surligné...
Je ne comprends pas... Et vous ?
Bonne nuit à vous,
Pierre

 

[Dranreb]

Peut être les "X" sont obtenus désormais par des formules ? Une cellule avec une formule ne peut jamais être vide, tout au plus peut-elle valoir un texte vide. Si c'est le cas, remplacez If Not IsEmpty(T(L, 1)) Then par If T(L, 1) <> "" Then

 

[Constantin]

C'est de fait le cas. J'ai pourtant fait des essais en virant la formule. Je recommence...
Ca a l'air de marcher... Du coup, je vais dormir un peu.
Bonne nuit ! Et encore merci !
Pierre