Variables et autres déclarations, Classées dans une Feuille et Écrites dans un Module VBA

**mjpmjp** · 27/04/2017, 18h59

bonjour,
avant tout, il faut savoir:
que j'utilise cette Feuille,
que le code n'est pas forcément extraordinaire et est perfectible, (à vous de jouer...)

à quoi çà peu servir ?
je pilote mes variables de cette feuille,
je note également des observations...

voilà des captures d'écran, je vous écris le code demain
@+JP

Tirroir Fermé
Nom : Capture1.PNG
Affichages : 262
Taille : 5,8 Ko

Nom : Capture1.PNG
Affichages : 262
Taille : 5,8 Ko

Tirroir Titre ouvert
Nom : Capture2.PNG
Affichages : 214
Taille : 10,4 Ko

module principal ouvert
Nom : Capture3.PNG
Affichages : 267
Taille : 94,7 Ko

le code ecrit automatiquement dans le module VBA
Nom : Capture4.PNG
Affichages : 250
Taille : 50,3 Ko

@+JP

**mjpmjp** · 27/04/2017, 21h24

bonjour,
dans le vba de la feuille, les événements:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private Sub Cmd_MenuOnOff_Click()
    If Test_TirroirBarreTitre_OnOff = False Then
        Test_TirroirBarreTitre_OnOff = True
        Cmd_MenuOnOff.Caption = "MENU  ON"
    Else
        Test_TirroirBarreTitre_OnOff = False
        Cmd_MenuOnOff.Caption = "MENU  OFF"
    End If
End Sub
Private Sub Worksheet_Activate()
    Call SystemINIT_TabModuleTirroir
    Cmd_MenuOnOff.Caption = "MENU  ON"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Test_OperationEnCours = False Then
        Call SystemSelectionChange(Target)
        Test_OperationEnCours = False
    End If
End Sub
Private Sub Cmd_FermeTirroir_Click()
    Call SystemFermeTirroir
End Sub
Private Sub Cmd_AjusteCodeTiroir_Click()
    Call SystemAjusteCodeTiroir
End Sub
Private Sub Cmd_InitialiserVariables_Click()
    Call SystemINIT_VariableSystem
End Sub
Private Sub Cmd_EnregistreVariables_Click()
    Call SystemEcrireVarDansModule
End Sub

**mjpmjp** · 27/04/2017, 21h47

bonjour,
dans le vba du Workbook:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
Private Sub Workbook_Open()
    Call SystemINIT_VariableSystem
End Sub

qui appelle la function qui a été ecrite par le code (vue de la capture ,au dessus)
cette function initialyse toutes les variables, par exemple ColorFond = (K8) = RGB(216,216,216)
quand le code trouve cette couleur il écrit "F" --> Fin de Data dans la variable DataModuleTirroir = "XXMTSDDDDDDDDDDFSDDDDDDDDDDDDDDDFSDDFSDDFM...X"

voici le code qui teste les couleurs et qui écrit "XXMTSDDDDDDDDDDFSDDDDDDDDDDDDDDDFSDDFSDDFM...X" dans DataModuleTirroir
chaque lettre correspond à une ligne le "XX" du début c'est pour le (0) du tableau et la ligne 1
les lignes "D" sont inertes, un autre système serait possible, du style M40T40S15S32...

SystemAjusteCodeTiroir

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Public Sub SystemAjusteCodeTiroir()
    'ecrit la ligne DataModuleTirroir destinée au tableau TabModuleTirroir
    'en fonction de la couleur .Interior.Color = RGB(0, 0, 0) de la colonne B
    'DataModuleTirroir = "XXMTSDDDDDDDDDDFSDDDDDDDDDDDDDDDFSDDFSDDFM...X" X=vide M=module T=tirroir  S=sous titre D=data F=fin data(fond)
    Dim n As Integer
    Dim LigneTest As Long
    'bloque evenement "Worksheet_SelectionChange"
    Test_OperationEnCours = True
    Application.ScreenUpdating = False
    'ouvre toutes les lignes --> démasque
    Rows("1:20000").Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select
    DataModuleTirroir = "XXMTSDDDDDDDDDDFSDDDDDDDDDDDDDDDFSDDFSDDFM"
    LigneTest = Len(DataModuleTirroir)
    '-----
    'test de la couleur colonne "B" pour :
    'M..les Modules
    'T..les Tirroir
    'X..FinSystemTirroir --> début = X
    'et avec la couleur colonne "C"
    'S..les SousTitre
    'D..les Data
    'F..les FinDeData
    '-----
    'boucle générale
    Do
        'Module
        If Range("B" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorModule).Interior.Color Then DataModuleTirroir = DataModuleTirroir & "M"
        'Tirroir
        If Range("B" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorTirroir).Interior.Color Then DataModuleTirroir = DataModuleTirroir & "T"
        'Data
        If Range("B" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorFond).Interior.Color Then
            If Range("C" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorFond).Interior.Color Then
                DataModuleTirroir = DataModuleTirroir & "F"
            Else
                If Range("C" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorSousTitreVariable).Interior.Color _
                Or Range("C" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorSousTitreCode).Interior.Color Then
                    DataModuleTirroir = DataModuleTirroir & "S"
                Else
                    DataModuleTirroir = DataModuleTirroir & "D"
                End If
            End If
        End If
        'Vide
        If Range("B" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorVide).Interior.Color Then DataModuleTirroir = DataModuleTirroir & "X": Exit Do
        LigneTest = LigneTest + 1
    Loop
    'Ecrire DataModuleTirroir Dans Onglet "SYSTEM"
    Range(Cell_DataModuleTirroir).Value = DataModuleTirroir
    'mettre les lignes (chaque n est une ligne) dans un tableau
    ReDim TabModuleTirroir(Len(DataModuleTirroir) + 1)
    For n = 0 To Len(DataModuleTirroir)
        TabModuleTirroir(n) = Mid(DataModuleTirroir, n + 1, 1)
    Next n
    'Ecrire Variables Dans Module "SystemINIT_VariableSystem"
    Call SystemEcrireVarDansModule
    Application.ScreenUpdating = True
    'débloque evenement "Worksheet_SelectionChange"
    Test_OperationEnCours = False
    'referme tout
    Call SystemFermeTirroir
    Call SystemINIT_VariableSystem
End Sub

à suivre, SystemEcrireVarDansModule

**mjpmjp** · 27/04/2017, 21h58

bonjour,
le code précédant, SystemAjusteCodeTiroir servait au fonctionnement des tirroirs qui peuvent contenir du contenu actif (variable) mais aussi passif (note,aide,...)

le code suivant écrit le contenu actif dans le module "SystemINIT_VariableSystem"

SystemEcrireVarDansModule

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Public Sub SystemEcrireVarDansModule()
    'Ecrire Variables Dans Module "SystemINIT_VariableSystem"
    Dim ModuleNew As Object
    Dim ModuleCode As Object
    Dim LigneTest As Integer
    Dim LigneTest2 As Integer
    'controle si pas d'appel direct de SystemAjusteCodeTiroir (Test_OperationEnCours = True)
    If Test_OperationEnCours = False Then Call SystemINIT_TabModuleTirroir
    Set ModuleNew = ThisWorkbook.VBProject.VBComponents("JP_SystemINIT_VariableSystem")
    Set ModuleCode = ModuleNew.CodeModule
    ModuleCode.DeleteLines 1, ModuleCode.CountOfLines
    ModuleCode.AddFromString "Option Explicit"
    LigneTest = 3
    'Parcourir tout le Module de Tirroir
    Do Until TabModuleTirroir(LigneTest) = "M" And Right(Range("L" & LigneTest).Value, 9) <> "Variables"
    'Parcourir tout le Tirroir
        If TabModuleTirroir(LigneTest) = "T" Then
            LigneTest = LigneTest + 1
            'si le Tirroir n'est pas vide (tirroir à un titre)
            If Range("M" & CStr(LigneTest - 1)).Value <> "" Then
                'ecrire le Titre du Tiroir (dans le module code)
                ModuleCode.AddFromString " "
                ModuleCode.AddFromString "'" & Range("M" & CStr(LigneTest - 1)).Value
                LigneTest2 = LigneTest
                'jusqu'à la fin du Tirroir (début nouveau Tirroir ou Module)
                Do Until TabModuleTirroir(LigneTest2) = "T" Or TabModuleTirroir(LigneTest2) = "M"
                    If Range("C" & CStr(LigneTest2)).Interior.Color = Range(Cell_ColorVariable).Interior.Color Then
                        If Range("C" & CStr(LigneTest2)).Value <> "" Then
                            If Range("I" & CStr(LigneTest2)).Value = "Const" Then
                                ModuleCode.AddFromString "Public Const Cell_" & Range("C" & CStr(LigneTest2)).Value & " = " & Chr(34) & "K" & LigneTest2 & Chr(34)
                            End If
                        End If
                    End If
                    LigneTest2 = LigneTest2 + 1
                Loop
            End If
        End If
        If Range("C" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorVariable).Interior.Color Then
            If Range("C" & CStr(LigneTest)).Value <> "" Then
                ModuleCode.AddFromString "Public " & Range("C" & CStr(LigneTest)).Value & " As " & Range("J" & CStr(LigneTest)).Value
            End If
        End If
        LigneTest = LigneTest + 1
    Loop
    'ligne vide (espace vertical)
    ModuleCode.AddFromString " "
    'titre de la function
    ModuleCode.AddFromString "Public Function SystemINIT_VariableSystem()"
    'ligne de code de la function
    LigneFunction = ModuleCode.ProcBodyLine("SystemINIT_VariableSystem", vbext_pk_Proc) + 1
    ModuleCode.InsertLines LigneFunction, "    'Détermine les variables adresse de cellule": LigneFunction = LigneFunction + 1
    ModuleCode.InsertLines LigneFunction, "    '==========================================": LigneFunction = LigneFunction + 1
    LigneTest = 3
    Do Until TabModuleTirroir(LigneTest) = "M" And Right(Range("L" & LigneTest).Value, 9) <> "Variables"
        If TabModuleTirroir(LigneTest) = "T" Then
            If Range("C" & CStr(LigneTest)).Value <> "" Then
                ModuleCode.InsertLines LigneFunction, "    ": LigneFunction = LigneFunction + 1
                ModuleCode.InsertLines LigneFunction, "    '" & Range("C" & CStr(LigneTest)).Value: LigneFunction = LigneFunction + 1
            End If
        End If
        If Range("C" & CStr(LigneTest)).Interior.Color = Range(Cell_ColorVariable).Interior.Color Then
            If Range("C" & CStr(LigneTest)).Value <> "" Then
                If Range("I" & CStr(LigneTest)).Value = "Const" Then
                    ModuleCode.InsertLines LigneFunction, "    " & Range("C" & CStr(LigneTest)).Value & _
                    " = Sheets(" & Chr(34) & "SYSTEM" & Chr(34) & ").Range(Cell_" & Range("C" & CStr(LigneTest)).Value & ").Value"
                    LigneFunction = LigneFunction + 1
                End If
            End If
        End If
        LigneTest = LigneTest + 1
    Loop
    'fin de la function
    ModuleCode.InsertLines LigneFunction, "End Function"
    Range("A1").Select
End Sub

à suivre, SystemINIT_TabModuleTirroir et SystemFermeTirroir

**mjpmjp** · 27/04/2017, 22h08

bonjour,
ce code écrit le contenu de la variable DataModuleTirroir = "XXMTSDDDDDDDDDDFSDDDDDDDDDDDDDDDFSDDFSDDFM...X" X=vide M=module T=tirroir S=sous titre D=data F=fin data(fond)
dans le tableau TabModuleTirroir : chaque (n) est une ligne --> n=0="X" , n=1=ligne1="X",...

SystemINIT_TabModuleTirroir

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
Public Function SystemINIT_TabModuleTirroir()
    Dim n As Integer
    'Charge la ligne DataModuleTirroir dans le tableau TabModuleTirroir
    'DataModuleTirroir = "XXMTDDD..." X=vide M=module T=tirroir D=data
    'TabModuleTirroir = Range(Cell_DataModuleTirroir).Value
    Call SystemINIT_VariableSystem
    ReDim TabModuleTirroir(Len(DataModuleTirroir) + 1)
    For n = 0 To Len(DataModuleTirroir)
        TabModuleTirroir(n) = Mid(DataModuleTirroir, n + 1, 1)
    Next n
End Function

ce code ferme tous les tirroirs, il masque toutes les lignes sauf celles des "M" Modules

SystemFermeTirroir

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Public Sub SystemFermeTirroir()
    Dim LigneFin As Integer
    LigneFin = 2
    Call SystemINIT_TabModuleTirroir
    Do
        If TabModuleTirroir(LigneFin) = "M" Then
            If Rows(LigneFin + 1).Hidden = False Then
                Range("Y" & LigneFin).Select
            End If
        End If
        If TabModuleTirroir(LigneFin) = "X" Then Exit Do
        LigneFin = LigneFin + 1
    Loop
    Range("A1").Select
End Sub

à venir le dernier code, SystemSelectionChange

**mjpmjp** · 27/04/2017, 22h25

bonjour,
enfin voila le dernier code qui gère l’événement "Change" quand on clique sur les barres de titres des tirroirs ou sur les bordures
le code utilise le tableau "TabModuleTirroir"
le controle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
    If LigneTarget > UBound(TabModuleTirroir) Then Exit Sub

est important, il permet de ne pas être en dehors du tableau

le controle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
   If Target.Column < 2 Or Target.Column > 25 Then

permet de ne pas solliciter le code si on est pas dans les colonnes voulues,

un dernier controle,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
    If Test_TirroirBarreTitre_OnOff = False Then
        If Chr(64 + Target.Column) <> "Y" Then

dans le cas ou on modifie les titres par exemple, on clique pour "MENU OFF"
et on controle si on clique sur la bordure, la colonne "Y"

SystemSelectionChange

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
 
Public Sub SystemSelectionChange(ByVal Target As Range)
    'déclaration de la variable dans "Worksheet_SelectionChange(ByVal Target As Range)"
    'LigneTarget = Ligne de la cellule sélectionnée
    Dim LigneTarget As Integer
    Dim LigneDeb As Integer
    Dim LigneFin As Integer
    If Test_OperationEnCours = True Then Exit Sub
    On Error GoTo GestionErreur
    LigneTarget = Target.Row
    If LigneTarget > UBound(TabModuleTirroir) Then Exit Sub
    LigneDeb = LigneTarget + 1
    LigneFin = LigneTarget + 1
    If Test_TirroirBarreTitre_OnOff = False Then
        If Chr(64 + Target.Column) <> "Y" Then
            Test_OperationEnCours = False
            Exit Sub
        Else
            Test_OperationEnCours = True
        End If
    Else
        If Target.Column < 2 Or Target.Column > 25 Then
            Test_OperationEnCours = False
            Exit Sub
        Else
            Test_OperationEnCours = True
        End If
    End If
 
    If TabModuleTirroir(LigneTarget) = "D" Or TabModuleTirroir(LigneTarget) = "F" Then Exit Sub
    If TabModuleTirroir(LigneTarget + 1) = "X" Then Exit Sub
    'Plage de Ligne Module
    If TabModuleTirroir(LigneTarget) = "M" Then
        Application.ScreenUpdating = False
        If Rows(LigneDeb).Hidden = False Then
            Do
                If TabModuleTirroir(LigneFin) = "M" Then Exit Do
                If TabModuleTirroir(LigneFin) = "X" Then Exit Do
                LigneFin = LigneFin + 1
            Loop
            Rows(LigneDeb & ":" & LigneFin - 1).Select
            Selection.EntireRow.Hidden = True
        Else
            Do
                If TabModuleTirroir(LigneFin) = "M" Then Exit Do
                If TabModuleTirroir(LigneFin) = "X" Then Exit Do
                If TabModuleTirroir(LigneFin) = "T" Then Rows(LigneFin).Hidden = False
                LigneFin = LigneFin + 1
            Loop
        End If
        Range("B" & Target.Row).Select
        Application.ScreenUpdating = True
    End If
    'Plage de Ligne Tirroir
    If TabModuleTirroir(LigneTarget) = "T" Then
        Application.ScreenUpdating = False
        If Rows(LigneDeb).Hidden = False Then
            Do
                If TabModuleTirroir(LigneFin) = "T" Then Exit Do
                If TabModuleTirroir(LigneFin) = "M" Then Exit Do
                If TabModuleTirroir(LigneFin) = "X" Then Exit Do
                LigneFin = LigneFin + 1
            Loop
            Rows(LigneDeb & ":" & LigneFin - 1).Select
            Selection.EntireRow.Hidden = True
        Else
            Do
                If TabModuleTirroir(LigneFin) = "X" Then Exit Do
                If TabModuleTirroir(LigneFin) = "M" Then Exit Do
                If TabModuleTirroir(LigneFin) = "T" Then Exit Do
                If TabModuleTirroir(LigneFin) = "S" Then Rows(LigneFin).Hidden = False
                LigneFin = LigneFin + 1
            Loop
        End If
        Range("B" & Target.Row).Select
        Application.ScreenUpdating = True
    End If
    'Plage de Ligne sousTitre
    If TabModuleTirroir(LigneTarget) = "S" Then
        Application.ScreenUpdating = False
        If Rows(LigneDeb).Hidden = False Then
            Do
                If TabModuleTirroir(LigneFin) = "S" Then Exit Do
                If TabModuleTirroir(LigneFin) = "T" Then Exit Do
                If TabModuleTirroir(LigneFin) = "M" Then Exit Do
                If TabModuleTirroir(LigneFin) = "X" Then Exit Do
                LigneFin = LigneFin + 1
            Loop
            Rows(LigneDeb & ":" & LigneFin - 1).Select
            Selection.EntireRow.Hidden = True
        Else
            Do
                If TabModuleTirroir(LigneFin) = "S" Then Exit Do
                If TabModuleTirroir(LigneFin) = "T" Then Exit Do
                If TabModuleTirroir(LigneFin) = "M" Then Exit Do
                LigneFin = LigneFin + 1
            Loop
            Rows(LigneDeb & ":" & LigneFin - 1).Select
            Selection.EntireRow.Hidden = False
        End If
    End If
    Range("B" & Target.Row).Select
    Application.ScreenUpdating = True
 
    Test_OperationEnCours = False
    Exit Sub
GestionErreur:
    ' Évalue le numéro d'erreur.
    Select Case Err.Number
        Case 9 'L'indice n'appartient pas à la sélection
            Test_OperationEnCours = False
            Call SystemINIT_TabModuleTirroir
        Case Else
            'Traite les autres situations ici...
    End Select
    'Reprend l'exécution au niveau de la ligne à l'origine de l'erreur
    Resume
End Sub

voila, je reviendrais sur ces tiroirs, avec un mécanisme sur des boutons "graphiques"
n’hésitez pas à secouer le code, c'est fait pour çà...

@+JP

**mjpmjp** · 27/04/2017, 23h39

bonjour,
comme prévu le lien vers un mécanisme sur des boutons "graphiques"
qui va utiliser les tirroirs...

http://www.developpez.net/forums/d16...stion-boutons/

@+JP

**mjpmjp** · 28/04/2017, 10h30

bonjour,
dans le cadre de la gestion des boutons de mon form --> "ListFilmSynchro" j'ai besoin de déclarer pour chaque bouton une variable
je vais donc ajouter, après le Module "M" système, un autre Module "M" pour les forms
dans ce Module "M" un Tiroir "T" pour chaque form
dans ce Tiroir "T" (avec pour titre --> ListFilmSynchro) je classe mes data, notamment mes variables dans un Sous Titre "S" que je titre "Variable"

mon nouvel espace... après avoir cliqué sur le bouton "Ajuste Code Tiroir"
Nom : Capture6.PNG
Affichages : 209
Taille : 16,1 Ko

Nom : Capture6.PNG
Affichages : 209
Taille : 16,1 Ko

dans cette capture, la variable DataModuleTirroir à bien été modifiée
Nom : Capture7.PNG
Affichages : 167
Taille : 4,0 Ko

dans le code VBA le module a été réécrit mais rien de nouveau, puisque notre espace était vide

MODIFICATION à envisager
en ce qui concerne les titres, pour que les variables soient écrites dans le code VBA, le titre du Module "M" doit se terminer par "Variables"

dans SystemEcrireVarDansModule

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
    'Parcourir tout le Module de Tirroir
    Do Until TabModuleTirroir(LigneTest) = "M" And Right(Range("L" & LigneTest).Value, 9) <> "Variables"

ce qui n'est pas top, il faudrait tester les Sous Titre "S"