XL 2021 Macro dans Macro

Constantin

XLDnaute Occasionnel
Supporter XLD
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
 

Pièces jointes

  • Courses déf archives2.xlsm
    286.3 KB · Affichages: 10
Solution
Remarquez: il serait possible de sélectionner les étiquette surlignées afin de pouvoir les parcourir par touche Tab :
VB:
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...

Constantin

XLDnaute Occasionnel
Supporter XLD
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)
 

Dranreb

XLDnaute Barbatruc
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

XLDnaute Occasionnel
Supporter XLD
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,
 

Pièces jointes

  • Courses déf essai5.xlsm
    289.2 KB · Affichages: 1

Dranreb

XLDnaute Barbatruc
Je trouve que la Sub IdentifierPointsCollecte marche bien dans votre dernier classeur du poste #19.
Ah, non, excuses, il manque MergeArea :
VB:
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.
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Remarquez: il serait possible de sélectionner les étiquette surlignées afin de pouvoir les parcourir par touche Tab :
VB:
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

XLDnaute Occasionnel
Supporter XLD
Alors là, c'est parfait ! :D

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

XLDnaute Occasionnel
Supporter XLD
Remarquez: il serait possible de sélectionner les étiquette surlignées afin de pouvoir les parcourir par touche Tab :
VB:
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.
 

Constantin

XLDnaute Occasionnel
Supporter XLD
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

XLDnaute Barbatruc
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
 

Discussions similaires

Statistiques des forums

Discussions
313 325
Messages
2 097 176
Membres
106 865
dernier inscrit
Greg02