Modification de plage d'application macro VBA

Version imprimable

18/06/2018, 16h47
fafri

1 pièce(s) jointe(s)

Modification de plage d'application macro VBA

Bonjour à tous

J'ai pris un fichier excal pour faire des arborescence, le fichier marche très bien, le seul souci que j'ai est la place de l'application de la macro, pour l'instant elle ne s'applique que sur les 10 premières lignes de la colonnes B, je voudrai étendre son utilisation à la totalité de la colonne B.

Merci d'avance à ceux qui pourront me donner une piste.

Je vous joint le fichier en exemple.
18/06/2018, 17h02
Jean-Philippe André

Bonjour,

Bienvenue sur DVP :salut:

Pour des raisons de sécurité, très peu de membres peuvent télécharger les fichiers en pièce jointe, aussi te serait-il possible de nous copier ici le code VBA en question, que l'on puisse te donner les meilleures pistes de résolution.

Merci

Bonjour Jean Philippe,

Excusez le noob que je suis , ci joint le code VBA

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
Option Explicit
 
Public gw_menu_bar As CommandBar
Public saisie As Variant
 
' Macro de lancement des differents choix des menus
Sub LanceMacro()
    saisie = Split(Application.CommandBars.ActionControl.Tag, "/") ' Eclatement de l'arborescence
End Sub
 
' Initialication du menu
Sub init_menu()
    Dim sm(300, 100) As Variant ' Dimentionnement des lignes et sous menus
    Dim tablo As Variant ' declaration d'un tableau pour les valeurs de chaque ligne
    Dim i As Integer ' pointeur de boucle
    Dim colonne As Integer ' Declaration des niveaux de sous menus
    Dim ligne(100) As Integer     ' Memoire du n° de ligne en fonction des sousmenus
    Dim drapeau As Boolean ' Variable pour sortir de la boucle while wend
    On Error Resume Next
    Application.CommandBars("Gw_menu_bar").Delete ' Destruction de la barre de menu popup
    On Error GoTo 0
    Set gw_menu_bar = Application.CommandBars.Add("Gw_menu_bar", msoBarPopup) ' Initialisation du menu popup
    colonne = 1 ' Initialisation de la colonne
    ligne(colonne) = 1 ' Initialisation de la ligne où commence le menu
    drapeau = True ' Initialisation du drapeau pour la boucle
    While drapeau = True
' ******************************************************************************************************************************
' permet d'eclater la commande dans un tablo : 2 parametres pour un Menu, 3 pour une ligne
' acutellement : tablo(0) : Libelle
'                tablo(1) : code B pour bouton, M pour Menu
'                tablo(2) : arborescence de l'élément par ex :DGA/PIL/DQP
'                tablo(3) : code O pour insérer un séparateur  de groupe avant
'
        tablo = Split(Sheets("Menu").Cells(ligne(colonne), colonne), ",") ' Eclatement de la ligne
'
'********************************************************************************************************************************
        If UCase(tablo(1)) = "B" Then ' Si c'est un bouton
           With gw_menu_bar
                If colonne = 1 Then ' C'est un bouton dans le menu de base, on traite alors par rapport à la barre de menu
                    Set sm(ligne(colonne), colonne) = .Controls.Add(msoControlButton, 1, , , True)
                    sm(ligne(colonne), colonne).Caption = tablo(0) ' Mise en place du titre
                    sm(ligne(colonne), colonne).Tag = tablo(2) ' Pareil, mais sur Tag
                    If UBound(tablo) > 2 Then
                        If tablo(3) = "O" Then sm(ligne(colonne), colonne).BeginGroup = True
                    End If
' ******************************************************************************************************************************
' LA macro lancée est actuellement la meme partout
                    sm(ligne(colonne), colonne).OnAction = "LanceMacro"   ' Lance cette Maco si click
' Attention, 5 lignes au dessous, il y a le meme Code pour des lignes appartenant aux sous niveaux des menus
' ******************************************************************************************************************************
 
                Else
                    Set sm(ligne(colonne), colonne) = sm(ligne(colonne - 1), colonne - 1).Controls.Add(msoControlButton, 1, , , True)
                    sm(ligne(colonne), colonne).Caption = tablo(0)
                    sm(ligne(colonne), colonne).Tag = tablo(2)
                    sm(ligne(colonne), colonne).OnAction = "LanceMacro"
                    If UBound(tablo) > 2 Then
                        If tablo(3) = "O" Then sm(ligne(colonne), colonne).BeginGroup = True
                    End If
                End If
            End With
        End If
        If UCase(tablo(1)) = "M" Then ' C'est un Menu, (Sous menu)
' Si la colonne = 2 alors je suis dans l'arborescence du menu (commandbar) sinon je suis dans un arborescence inferieure
' Le controle n'est plus gw_menu_bar, mais le controle du niveau superieur (sm(x,y) gardé dans une table)
            If colonne = 1 Then ' 1er niveau
                Set sm(ligne(colonne), colonne) = gw_menu_bar.Controls.Add(msoControlPopup, , , , True) ' Creation d'un type sous menu
            Else ' Niveaux inferieurs
                Set sm(ligne(colonne), colonne) = sm(ligne(colonne - 1), colonne - 1).Controls.Add(msoControlPopup, , , , True) ' Creation d'un type sous menu
            End If
            sm(ligne(colonne), colonne).Caption = tablo(0) ' Mise en place du titre
            If UBound(tablo) > 2 Then
                If tablo(3) = "O" Then sm(ligne(colonne), colonne).BeginGroup = True
            End If
            colonne = colonne + 1 ' Avancer dans la colonne
            ' Recherche du sousmenu dans la colonne suivante
            For ligne(colonne) = 1 To Sheets("Menu").Cells(65536, colonne).End(xlUp).Row
                If tablo(0) = Sheets("Menu").Cells(ligne(colonne), colonne) Then
                Exit For ' Oui j'ai trouvé
                End If
            Next
            If ligne(colonne) > Sheets("Menu").Cells(65536, colonne).End(xlUp).Row Then ' Je n'ai pas trouvé
                colonne = colonne - 1 ' Retour à la colonne précédente
                MsgBox "Sous menu : " & tablo(0) & " Non trouvé" ' Message d'erreur
            End If
        End If
recompte:
        ligne(colonne) = ligne(colonne) + 1 ' Avancer d'une ligne
        If Sheets("Menu").Cells(ligne(colonne), colonne) = "//" Then ' Je teste si je suis en fin de menu
            If colonne = 1 Then ' Si c'est le menu de base, fin de la boucle
                drapeau = False ' Pointeur de fin de boucle
            Else
                colonne = colonne - 1 ' Je recule d'une colonne
                GoTo recompte ' Je retourne pour ajouter une ligne et je recontrole
            End If
        End If
    Wend
    gw_menu_bar.ShowPopup
End Sub

Salut

Pas de chance, la partie du code que tu fournis ne permet pas de répondre :)

Alors voici quelques modifications, je n'ai pas regarder init_menu mais il y a sans doute des choses à faire à la vu du reste :p Mais il est trop tard pour ce soir ;)
Voici les modifications que je propose, si j'ai bien compris le contenu du menu ne change pas en cours d'utilisation du fichier? Si c’était le cas, il suffirait de mettre un init_menu dans le change de la feuille Menu.

Pour l'instant voila
La dernière ligne de Init_menu doit être mise en commentaire

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
recompte:
        ligne(colonne) = ligne(colonne) + 1 ' Avancer d'une ligne
        If Sheets("Menu").Cells(ligne(colonne), colonne) = "//" Then ' Je teste si je suis en fin de menu
            If colonne = 1 Then ' Si c'est le menu de base, fin de la boucle
                drapeau = False ' Pointeur de fin de boucle
            Else
                colonne = colonne - 1 ' Je recule d'une colonne
                GoTo recompte ' Je retourne pour ajouter une ligne et je recontrole
            End If
        End If
    Wend
    'gw_menu_bar.ShowPopup
End Sub

Dans Feuil3 et Feuil2, il faut modifier ainsi, d'ailleurs vu que le code est le même il peut être placer dans thisworkbook en faisant une petite modification

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim AvantSaisie0, AvantSaisie1, AvantSaisie2  'c,i, AvantSaisie,lgn, col
'    i = 0
    If Target.Count > 1 Then Exit Sub
'    For Each c In Target    'pas de menu si sélection multiple
'        i = i + 1
'        If i > 1 Then Exit Sub
'    Next c
'    lgn = Target.Row
'    col = Target.Column
    With Target.Worksheet
        AvantSaisie0 = Target.Value '.Cells(lgn, col)
        AvantSaisie1 = Target.Offset(, 1).Value '.Cells(lgn, col + 1).Value
        AvantSaisie2 = Target.Offset(, 2).Value '.Cells(lgn, col + 2).Value
        'AvantSaisie = Split(AvantSaisie0 & "/" & AvantSaisie1 & "/" & AvantSaisie2, "/")
        'AvantSaisie ne semble plus utile puisque qu'il n'est plus utilisé dans la suite du code
        'saisie = AvantSaisie    'corrige le bug : au cas où le menu est quitté sans choix par changement de sélection, c'est validé avec le chois antérieur!
        saisie = Array(AvantSaisie0, AvantSaisie1, AvantSaisie2)
'Ta limitation est ici, il suffit de modifier B10
        If Not Intersect(Target, .Range("B3:B10")) Is Nothing Then 'acivation pour les colonnes "quoi"
            'Il est étrange d'initialiser le menu à chaque fois, il serait plus judicieux de ne le faire qu'une fois
            'Par exemple dans le open du ThisWorkBook
            'init_menu  'créaton du menu
            'Affiche le menu
            gw_menu_bar.ShowPopup
            Target.Value = saisie(0) '.Cells(lgn, col).Value = Saisie(0)
            Target.Offset(, 1).Value = saisie(1) '.Cells(lgn, col + 1) = Saisie(1)
            Target.Offset(, 2).Value = saisie(2) '.Cells(lgn, col + 2) = Saisie(2)
        End If
    End With
End Sub

J'ai laissé en commentaire des bouts de l'ancien code pour la compréhension des modification, mais pour l'exploitation du fichier tu peux nettoyer
Le but est de juste afficher le menu sans le recréer à chaque fois, tu vas voir le temps de chargement du menu est magic ;)

Le chargement du menu se fait à l'ouverture du classeur (pour tester, une fois les modification faite, il faudra que tu relances ton fichier)
Code à mettre dans le ThisWorkBook

Code:

1
2
3
Private Sub Workbook_Open()
init_menu
End Sub

++
Qwaz

19/06/2018, 09h29
fafri

Merci qwazety, en effet la vitesse de l'ouverture du menu est devenu assez magique, excellent. Tu as également raison, le contenu du menu ne change pas au cours de l'utilisation du fichier.

Quelle partie du code renseigne le range de l'application de la macro du coup? J'ai beau chercher je trouve pas, ma macro est optimisée au max la mais le range ne vas toujours pas, tu as des pistes la dessus?

Infiniment merci encore
19/06/2018, 09h33
fafri

Autant pour moi qwazerty, j'ai relu tes commentaires, ma limitation dans le range B3:B10 quand je la modifie pour l'élargir, ça me renvoie une erreur.
19/06/2018, 09h39
fafri

C'est bon qwazerty, il fallait également que je modifie la déclaration sm en même temps, ça a l'air de marcher royalement bien et optimisé à la perfection. J'ai eu quelques bug quand j'ai chercher à agrandir la taille de mes menus, pour l'instant ça fonctionne bien avec ce que j'ai à mettre, j'aurai peut être des soucis à l'avenir.

Merci du coup de main, t'as sauvé la mise sur ce coup.