Frise chronologique avec des dates.

**licpegpon** · 16/11/2018, 19h33

Bonjour,
J obtiens d une macro plusieurs dates importantes d un projet (objectif, réalisé, intermédiaire, ...) et je voudrais faire apparaître toutes ces dates avec un texte explicatif pour chaque date sur un segment représentant le temps. Je cherche à avoir une représentation graphique de toutes ces dates. Quelque chose de visuel. Si quelqu un a une proposition ?
Cdlt.
Jérôme

**Theze** · 16/11/2018, 22h36

Bonjour,

Quelque chose comme un diagramme de Gantt ?

**licpegpon** · 17/11/2018, 12h22

Beaucoup plus simple. Une ligne représentant le temps et des dates positionnées dans l ordre sur ce segment.
Cdlt.
Par exemple :
1 ére date à gauche : commande
Ensuite validation commande
Target
Date livraison
...

Cdlt
Jérôme

**Theze** · 17/11/2018, 14h16

Ci-dessous un code qui va paramétrer des cellules avec des couleurs différentes au prorata des différentes dates :

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
 
Sub Test()
 
    Dim Tbl(1 To 2, 1 To 7)
    Dim TSegment
    Dim TDate
    Dim DifDate As Long
    Dim Col As Long
    Dim I As Long
    Dim J As Long
    Dim K As Integer
 
    TSegment = Array("Commande", "Intermédiaire 1", "Intermédiaire 2", "Intermédiaire 3", "Intermédiaire 4", "Intermédiaire 5", "Livraison")
 
    TDate = Array("01/01/2018", "01/03/2018", "01/04/2018", "01/08/2018", "01/09/2018", "01/11/2018", "01/01/2019")
 
    For I = 1 To 7
 
        Tbl(1, I) = TSegment(I - 1)
        Tbl(2, I) = CDate(TDate(I - 1))
 
    Next I
 
    DifDate = Tbl(2, UBound(Tbl, 2)) - Tbl(2, LBound(Tbl, 2))
 
    Application.ScreenUpdating = False
    For I = 1 To DifDate: Columns(I).ColumnWidth = 1: Next I
    Application.ScreenUpdating = True
 
    K = 2
 
    For I = LBound(Tbl, 2) To UBound(Tbl, 2) - 1
 
        K = K + 1
 
        Range(Cells(2, J + 1), Cells(2, J + (Tbl(2, I + 1) - Tbl(2, I)))).Interior.ColorIndex = K
 
        Col = J + 1 + CLng(((J + (Tbl(2, I + 1) - Tbl(2, I))) - (J + 1)) / 2)
 
        Cells(1, Col).Value = Tbl(1, I)
 
        J = J + (Tbl(2, I + 1) - Tbl(2, I))
 
    Next I
 
End Sub

On peut utiliser des Shapes à la place des cellules mais si tu veux un résultat particulier, poste un classeur exemple

**licpegpon** · 17/11/2018, 19h40

J y regarde dès lundi et vous tiens informé. Gros travail...merci beaucoup.
Cdlt.
Jérôme

**licpegpon** · 19/11/2018, 08h35

Bonjour,

Ci-dessous une copie d'écran de ce que je souhaiterais.....

Nom : Présentation1.jpg
Affichages : 7175
Taille : 41,8 Ko

Votre macro pourrait me servir pour d'autres réalisations. Un grand merci pour le temps passé...

Cdlt.
Jérôme

**Theze** · 20/11/2018, 07h33

Bonjour,

Code à tester pour vois si ça convient. Deux tableaux sont ici utiliser pour l'exemple mais il peuvent être remplacés par des valeurs situées sur une feuille. Le tableau "Tbl()" est seulement dimensionné de 1 à 7 et ceci aussi pour l'exemple, il devra être dimensionné par rapport aux nombre de valeurs réelles :

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
 
Sub Test()
 
    Dim Fe As Worksheet
    Dim Fleche As Shape
    Dim Trait As Shape
    Dim Texte As Shape
    Dim Tbl(1 To 2, 1 To 7)
    Dim TSegment
    Dim TDate
    Dim DifDate As Long
    Dim I As Long
    Dim HautFleche As Integer
    Dim GaucheFleche As Long
    Dim EpaisFleche As Integer
    Dim HautTrait As Integer
    Dim GaucheTrait As Long
    Dim EpaisTrait As Integer
    Dim Coeff As Single
 
    GaucheFleche = 50
    HautFleche = 50
    EpaisFleche = 10
    EpaisTrait = 1
    HautTrait = 30
 
    Coeff = 2 'coefficient pour agrandir la zone dans le cas où les Labels se chevauche
 
    Set Fe = ActiveSheet
 
    'supprime tous les Shapes avant de créer le graphique
    For Each Fleche In Fe.Shapes: Fleche.Delete: Next Fleche
 
    'ces deux tableaux servent pour l'exemple, les valeurs peuvent être récupérées sur une feuille
    TSegment = Array("Commande", "Intermédiaire 1", "Intermédiaire 2", "Intermédiaire 3", "Intermédiaire 4", "Intermédiaire 5", "Livraison")
    TDate = Array("01/01/2018", "10/02/2018", "01/04/2018", "15/07/2018", "01/09/2018", "10/11/2018", "01/01/2019")
 
    'inscrit dans un seul tableau
    For I = 1 To 7
 
        Tbl(1, I) = TSegment(I - 1)
        Tbl(2, I) = CDate(TDate(I - 1))
 
    Next I
 
    'durée du projet multiplié par le coefficient afin d'éviter le chevauchement des Labels
    DifDate = (Tbl(2, UBound(Tbl, 2)) - Tbl(2, LBound(Tbl, 2))) * Coeff
 
    'flèche horizontale
    Set Fleche = Fe.Shapes.AddShape(msoShapeRightArrow, GaucheFleche, HautFleche, DifDate, EpaisFleche)
 
    'pose des traits verticaux et des zones de texte (Label)
    For I = 1 To UBound(Tbl, 2) - 1
 
        'traits verticaux
        GaucheTrait = GaucheTrait + (Tbl(2, I + 1) - Tbl(2, I)) * Coeff 'doit aussi être multiplié par le coefficient
        Set Trait = Fe.Shapes.AddShape(msoShapeBevel, GaucheTrait, (HautFleche + EpaisFleche / 2) - HautTrait / 2, EpaisTrait, HautTrait)
 
        'zone de titre pour les dates
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche + EpaisFleche / 2) + HautTrait / 2 + 10, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Characters.Text = Tbl(2, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
        'zone de texte pour les étapes
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche - EpaisFleche / 2) - HautTrait, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Characters.Text = Tbl(1, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
    Next I
 
End Sub

**licpegpon** · 20/11/2018, 09h34

Bonjour Thèze,

Je suis scotché !!! Ouaouh !! Très bon et beau boulot. Je teste et fais un retour.

Cdlt.
Jérôme.

**licpegpon** · 20/11/2018, 10h37

Bonjour Thèze,

J'ai adapté le programme à mon cas en récupérant dans TSegment le texte de ce que je veux afficher, en l'occurence :

"PO Date"
"Deliv Date OTD1"
"Deliv Target Date"
"Last Rejection Date"
"Deliv Date OTD2"
"Deliv note Test"
"Deliv note A"
"Good Receipt"

J'ai mis dans TDate la localisation de l'information que je récupére. Toutes les infos se trouvent dans l'onglet "ADD_INFOS" à différents endroits.

Lorsque j'exécute la macro j'ai une erreur à la ligne For Each Fleche In Fe.Shapes: Fleche.Delete: Next Fleche.
La valeur tapée est en dehors des limites...

Je précise que je suis débutant. J'avoue ne pas tout comprendre à ton code, ce qui ne m'arrange pas bien sûr pour l'adapter à mon cas. Il est fort probable que j'ai oublié des modifs ou fait des erreurs....Il faut bien sûr que les infos soient affichées dans l'ordre chronologique car en fonction du cas les titres peuvent bouger et ne pas être dans le même ordre. Quoi qu'il en soit un grand merci par avance.

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
Sub Test()
 
    Dim Fe As Worksheet
    Dim Fleche As Shape
    Dim Trait As Shape
    Dim Texte As Shape
    Dim Tbl(1 To 2, 1 To 8)
    Dim TSegment
    Dim TDate
    Dim DifDate As Long
    Dim I As Long
    Dim HautFleche As Integer
    Dim GaucheFleche As Long
    Dim EpaisFleche As Integer
    Dim HautTrait As Integer
    Dim GaucheTrait As Long
    Dim EpaisTrait As Integer
    Dim Coeff As Single
 
    GaucheFleche = 50
    HautFleche = 50
    EpaisFleche = 10
    EpaisTrait = 1
    HautTrait = 30
 
    Coeff = 2 'coefficient pour agrandir la zone dans le cas où les Labels se chevauchent
 
    Set Fe = ActiveSheet
 
    'supprime tous les Shapes avant de créer le graphique
    For Each Fleche In Fe.Shapes: Fleche.Delete: Next Fleche
 
    'ces deux tableaux servent pour l'exemple, les valeurs peuvent être récupérées sur une feuille
    TSegment = Array("PO Date", "Deliv Date OTD1", "Deliv Target Date", "Last Rejection Date", "Deliv Date OTD2", "Deliv note Test", "Deliv note A", "Good Receipt")
    TDate = Array(ADD_INFOS!C9, ADD_INFOS!H8, ADD_INFOS!H6, ADD_INFOS!H11, ADD_INFOS!H13, ADD_INFOS!F21, ADD_INFOS!F22, ADD_INFOS!E30)
 
    'inscrit dans un seul tableau
    For I = 1 To 8
 
        Tbl(1, I) = TSegment(I - 1)
        Tbl(2, I) = CDate(TDate(I - 1))
 
    Next I
 
    'durée du projet multiplié par le coefficient afin d'éviter le chevauchement des Labels
    DifDate = (Tbl(2, UBound(Tbl, 2)) - Tbl(2, LBound(Tbl, 2))) * Coeff
 
    'flèche horizontale
    Set Fleche = Fe.Shapes.AddShape(msoShapeRightArrow, GaucheFleche, HautFleche, DifDate, EpaisFleche)
 
    'pose des traits verticaux et des zones de texte (Label)
    For I = 1 To UBound(Tbl, 2) - 1
 
        'traits verticaux
        GaucheTrait = GaucheTrait + (Tbl(2, I + 1) - Tbl(2, I)) * Coeff 'doit aussi être multiplié par le coefficient
        Set Trait = Fe.Shapes.AddShape(msoShapeBevel, GaucheTrait, (HautFleche + EpaisFleche / 2) - HautTrait / 2, EpaisTrait, HautTrait)
 
        'zone de titre pour les dates
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche + EpaisFleche / 2) + HautTrait / 2 + 10, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Characters.Text = Tbl(2, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
        'zone de texte pour les étapes
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche - EpaisFleche / 2) - HautTrait, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Characters.Text = Tbl(1, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
    Next I
 
End Sub

**Theze** · 20/11/2018, 15h16

Bizarre car il n'y a pas de raison que cette ligne de code génère une erreur puisque même si il n'y a aucun Shape sur la feuille la boucle saute l'instruction de suppression ?
Voici un classeur test avec les valeurs dans les cellules que tu as indiqué. j'ai ajouté deux boutons, un pour supprimer tout le traçage et l'autre pour effectuer le traçage :
Test Graphique.xlsm

**licpegpon** · 20/11/2018, 15h54

(Re)bonjour,

Votre fichier fonctionne parfaitement. J'ai intégré vos macros dans mon fichier et j'ai toujours des pb. Ci-joint le fichier sur lequel j'ai effacé des infos. Toutes les valeurs sont bidons c'est juste pour le test.
Au fait je souihaiterais que le tracé s'effectue dans l'onglet "DATES". J'avais pour cela créé des boutons reliés aux macros (2 boutons donc comme dans votre fichier), le pb c'est que lorsque j'exécute la macro tout est effacé.... Je me disais que peut-être il faudrait mettre les boutons dans l'onglet "ADD_INFOS" et que le tracé se fasse dans l'onglet "DATES". Façon de contourner le pb....

**Theze** · 20/11/2018, 16h57

C'est la date en E30 qui n'est pas conforme !
Tu as la valeur 31/9/18, si 9 représente le mois, septembre comporte 30 jours et non 31 !

**Theze** · 20/11/2018, 17h37

Attention aussi, il y a un défaut de chronologie, il te faut inverser les valeurs des cellules H6 et H8 dans le tableau (ce qui est fait dans le code ci-dessous).
Le code qui suit met les Labels en position verticale car comme il y a un assez grand délai entre C9 (début) et H8 (128 jours), les dates ayant un délai entre elles plus petit, elles se trouvent relativement près les unes des autres et donc, les Labels se chevauchent :

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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
 
Sub Tracer()
 
    Dim Fe As Worksheet
    Dim Fleche As Shape
    Dim Trait As Shape
    Dim Texte As Shape
    Dim Tbl(1 To 2, 1 To 8)
    Dim TSegment
    Dim TDate
    Dim DifDate As Long
    Dim I As Long
    Dim HautFleche As Integer
    Dim GaucheFleche As Long
    Dim EpaisFleche As Integer
    Dim HautTrait As Integer
    Dim GaucheTrait As Long
    Dim EpaisTrait As Integer
    Dim Coeff As Single
 
    GaucheFleche = 50
    HautFleche = 200
    EpaisFleche = 10
    EpaisTrait = 1
    HautTrait = 30
 
    Coeff = 4 'coefficient pour agrandir la zone dans le cas où les Labels se chevauchent
 
    Set Fe = ActiveSheet
 
    'supprime tous les Shapes avant de créer le graphique
    Effacer
 
    'tableaux des textes pour les Labels
    TSegment = Array("PO Date", _
                     "Deliv Date OTD1", _
                     "Deliv Target Date", _
                     "Last Rejection Date", _
                     "Deliv Date OTD2", _
                     "Deliv note Test", _
                     "Deliv note A", _
                     "Good Receipt")
 
    With Worksheets("ADD_INFOS")
 
        TDate = Array(.[C9], _
                      .[H6], _
                      .[H8], _
                      .[H11], _
                      .[H13], _
                      .[F21], _
                      .[F22], _
                      .[E30])
 
    End With
 
    'inscrit dans un seul tableau
    For I = 1 To 8
 
        Tbl(1, I) = TSegment(I - 1)
        Tbl(2, I) = CDate(TDate(I - 1))
 
    Next I
 
    'durée du projet multiplié par le coefficient afin d'éviter le chevauchement des Labels
    DifDate = (Tbl(2, UBound(Tbl, 2)) - Tbl(2, LBound(Tbl, 2))) * Coeff
 
    'flèche horizontale
    Set Fleche = Fe.Shapes.AddShape(msoShapeRightArrow, GaucheFleche, HautFleche, DifDate, EpaisFleche)
 
    'pose des traits verticaux et des zones de texte (Label)
    For I = 1 To UBound(Tbl, 2) - 1
        'traits verticaux
        GaucheTrait = GaucheTrait + (Tbl(2, I + 1) - Tbl(2, I)) * Coeff 'doit aussi être multiplié par le coefficient
 
        Set Trait = Fe.Shapes.AddShape(msoShapeBevel, GaucheTrait, (HautFleche + EpaisFleche / 2) - HautTrait / 2, EpaisTrait, HautTrait)
 
        'zone de texte pour les dates
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche + EpaisFleche / 2) + HautTrait / 2 + 10, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Orientation = msoTextOrientationVertical
                .Characters.Text = Tbl(2, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Rotation = 180
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Top = (HautFleche + EpaisFleche / 2) + HautTrait / 2 '+ 10
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
        'zone de texte pour les étapes
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche - EpaisFleche / 2) - HautTrait, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Orientation = msoTextOrientationVertical
                .Characters.Text = Tbl(1, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Rotation = 180
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Top = (HautFleche + EpaisFleche / 2) - .Height - HautTrait + 10
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
    Next I
 
End Sub

**licpegpon** · 20/11/2018, 18h02

J'ai corrigé la date en E30. Effectivement une boulette de ma part en entrant une date bidon....

Deux questions......

1) Si je comprends bien les infos rentrées dans TSegment correspondent respectivement à celles entrées dans Tdate. C'est à dire que :

"PO Date" correspond à la valeur en C9
"Deliv Date OTD1" correspond à la valeur en H6
...

Est-ce bien cela ?

Dans l'affirmative :
PO Date --> C9
Deliv Date OTD1 --> H8 (et non H6 !!)

2) En fonction des cas, l'ordre entre les données peut être différent. En effet si la livraison est en retard alors Deliv date OTD1 > Deliv Target Date
si la livraison est en avance Deliv date OTD1 < Deliv Target Date.....
Tout cela pour dire que l'ordre entre les différentes données doit se faire automatiquement en fonction du cas...

Je ne sais pas si je suis clair ?.....

Merci encore.

Cdlt.
Jérôme.

**Theze** · 21/11/2018, 06h37

Bonjour,

Deliv Date OTD1 --> H8 (et non H6 !!)

2) En fonction des cas, l'ordre entre les données peut être différent. En effet si la livraison est en retard alors Deliv date OTD1 > Deliv Target Date
si la livraison est en avance Deliv date OTD1 < Deliv Target Date.....
Tout cela pour dire que l'ordre entre les différentes données doit se faire automatiquement en fonction du cas...

Ok, c'est bon, je pensais qu'il ne pouvais pas y avoir de date inférieure à une autre de plus, j'ai fais la permutation des dates dans le tableau "TDate()" et je n'ai pas penser à permuter dans "TSegment()" !
De toute façon, le graphique fonctionne aussi, le tout c'est que la différence entre la date de début en C9 et celle de fin en E30 soit positive car la construction des Shapes n'accepte pas les valeurs négatives pour Width et Height !

**licpegpon** · 21/11/2018, 10h17

Bonjour,

Est-ce bien cela ? --> Il y a correspondance entre les infos apparaissant dans TSegment et Tdate ?

Ce que je veux dire :

Code :

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

1
2
3
4
5
6
7
8
Si TSegment = Array("PO Date", _
                     "Deliv Date OTD1", _
                     "Deliv Target Date", _
                     "Last Rejection Date", _
                     "Deliv Date OTD2", _
                     "Deliv note Test", _
                     "Deliv note A", _
                     "Good Receipt")

et

Code :

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

1
2
3
4
5
6
7
8
        TDate = Array(.[C9], _
                      .[H6], _
                      .[H8], _
                      .[H11], _
                      .[H13], _
                      .[F21], _
                      .[F22], _
                      .[E30])

Ceci signifie t-il que :

"PO Date" correspond à C9
"Deliv Date OTD1" correspond à H6
"Deliv Target Date" correspond à H8
...

??

Cdlt.
Jérôme

**licpegpon** · 21/11/2018, 10h20

Concernant l'ordre d'apparition des valeurs sur la frise, cela va être variable en fonction du cas. Ce que je veux dire c'est que l'ordre peut être très différent d'un cas à l'autre.

On peut avoir "PO date" après "deliv OTD1" ou le contraire, etc .... La macro gère t-elle automatiquement l'ordre d'apparition des infos ?

Cdlt.
Jérôme.

**Theze** · 21/11/2018, 16h30

Il y a bien correspondance entre les deux tableaux :
"PO Date" --> [C9]
"Deliv Date OTD1" --> [H8]
"Deliv Target Date" --> [H6]
"Last Rejection Date" --> [H11]
"Deliv Date OTD2" --> [H13]
"Deliv note Test" --> [F21]
"Deliv note A" --> [F22]
"Good Receipt" --> [E30]

et la boucle ci-dessous :

Code :

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

1
2
3
4
5
6
7
 
For I = 1 To 8
 
    Tbl(1, I) = TSegment(I - 1)
    Tbl(2, I) = CDate(TDate(I - 1))
 
Next I

...permet de faire correspondre dans le tableau de regroupement les deux autres tableaux.
Voici le code avec un seul tableau. J'ai rajouté une partie pour tracer un trait sur le graphique pour représenter la date du jour en cours et ça, seulement si la date du jour est inférieure à la date de fin (cellule E30). Pour tester, change la valeur dans E30 afin qu'elle soit supérieure à la date du jour (aujourd'hui, le 21/11/2018) :

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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
 
Sub Tracer()
 
    Dim Fe As Worksheet
    Dim Fleche As Shape
    Dim Trait As Shape
    Dim Texte As Shape
    Dim Tbl(1 To 2, 1 To 8)
    Dim DifDate As Long
    Dim I As Long
    Dim HautFleche As Integer
    Dim GaucheFleche As Long
    Dim EpaisFleche As Integer
    Dim HautTrait As Integer
    Dim GaucheTrait As Long
    Dim EpaisTrait As Integer
    Dim Coeff As Single
 
    GaucheFleche = 50
    HautFleche = 200
    EpaisFleche = 10
    EpaisTrait = 1
    HautTrait = 30
 
    Coeff = 4 'coefficient pour agrandir la zone dans le cas où les Labels se chevauchent
 
    Set Fe = ActiveSheet
 
    'supprime tous les Shapes avant de créer le graphique
    Effacer
 
    'tableau à deux dimensions dont la première contient les segments et la seconde les dates
    With Worksheets("ADD_INFOS")
 
        Tbl(1, 1) = "PO Date":             Tbl(2, 1) = CDate(.[C9])
        Tbl(1, 2) = "Deliv Date OTD1":     Tbl(2, 2) = CDate(.[H8])
        Tbl(1, 3) = "Deliv Target Date":   Tbl(2, 3) = CDate(.[H6])
        Tbl(1, 4) = "Last Rejection Date": Tbl(2, 4) = CDate(.[H11])
        Tbl(1, 5) = "Deliv Date OTD2":     Tbl(2, 5) = CDate(.[H13])
        Tbl(1, 6) = "Deliv note Test":     Tbl(2, 6) = CDate(.[F21])
        Tbl(1, 7) = "Deliv note A":        Tbl(2, 7) = CDate(.[F22])
        Tbl(1, 8) = "Good Receipt":        Tbl(2, 8) = CDate(.[E30])
 
    End With
 
    'durée du projet multiplié par le coefficient afin d'éviter le chevauchement des Labels
    DifDate = (Tbl(2, UBound(Tbl, 2)) - Tbl(2, LBound(Tbl, 2))) * Coeff
 
    'flèche horizontale
    Set Fleche = Fe.Shapes.AddShape(msoShapeRightArrow, GaucheFleche, HautFleche, DifDate, EpaisFleche)
 
    'pose des traits verticaux et des zones de texte (Label)
    For I = 1 To UBound(Tbl, 2) - 1
 
        'traits verticaux
        GaucheTrait = GaucheTrait + (Tbl(2, I + 1) - Tbl(2, I)) * Coeff 'doit aussi être multiplié par le coefficient
 
        '58 correspond à une flèche double pointant vers le haut et le bas !
        Set Trait = Fe.Shapes.AddShape(58, GaucheTrait, (HautFleche + EpaisFleche / 2) - HautTrait / 2, EpaisTrait, HautTrait)
 
        'zone de texte pour les dates
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche + EpaisFleche / 2) + HautTrait / 2 + 10, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Orientation = msoTextOrientationVertical
                .Characters.Text = Tbl(2, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Rotation = 180
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Top = (HautFleche + EpaisFleche / 2) + HautTrait / 2 '+ 10
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
        'zone de texte pour les étapes
        Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche - EpaisFleche / 2) - HautTrait, 100, 20)
 
        'sans marge, et transparent pour le fond et les bordures
        With Texte
 
            With .TextFrame
 
                .Orientation = msoTextOrientationVertical
                .Characters.Text = Tbl(1, I)
                .AutoSize = True
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
 
            End With
 
            .Rotation = 180
            .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
            .Top = (HautFleche + EpaisFleche / 2) - .Height - HautTrait + 10
            .Fill.Transparency = 1
            .Line.Transparency = 1
 
        End With
 
    Next I
 
    'si le délai est dépassé, il ne sert plus à rien de matérialisé la date du jour sur le graphique
    If Date > Tbl(2, UBound(Tbl, 2)) Then Exit Sub
 
    'défini la position du trait vertical de la date d'aujourd'hui
    GaucheTrait = GaucheFleche + (Date - Tbl(2, 1)) * Coeff  'doit aussi être multiplié par le coefficient
 
    '58 correspond à une flèche double pointant vers le haut et le bas !
    Set Trait = Fe.Shapes.AddShape(58, GaucheTrait, (HautFleche + EpaisFleche / 2) - HautTrait / 2, EpaisTrait, HautTrait)
 
    'colore le trait symbolisant la date d'aujourd'hui en rouge
    Trait.Fill.ForeColor.RGB = RGB(255, 0, 0)
    Trait.Line.ForeColor.RGB = RGB(255, 0, 0)
 
    'aujourd'hui
    Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche - EpaisFleche / 2) - HautTrait, 100, 20)
 
    'sans marge, et transparent pour le fond et les bordures
    With Texte
 
        With .TextFrame
 
            .Orientation = msoTextOrientationVertical
            .Characters.Text = "Aujourd'hui"
            .AutoSize = True
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .MarginBottom = 0
 
        End With
 
        .Rotation = 180
        .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
        .Top = (HautFleche + EpaisFleche / 2) - .Height - HautTrait + 10
        .Fill.Transparency = 1
        .Line.Transparency = 1
 
    End With
 
    Set Texte = Fe.Shapes.AddLabel(msoTextOrientationHorizontal, 1, (HautFleche + EpaisFleche / 2) + HautTrait / 2 + 10, 100, 20)
 
    'sans marge, et transparent pour le fond et les bordures
    With Texte
 
        With .TextFrame
 
            .Orientation = msoTextOrientationVertical
            .Characters.Text = Date
            .AutoSize = True
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .MarginBottom = 0
 
        End With
 
        .Rotation = 180
        .Left = GaucheTrait - (.Width / 2 + EpaisTrait / 2)
        .Top = (HautFleche + EpaisFleche / 2) + HautTrait / 2
        .Fill.Transparency = 1
        .Line.Transparency = 1
 
    End With
 
End Sub

**licpegpon** · 21/11/2018, 17h15

Bonjour,

Je viens d'intégrer ces deux procédures dans mon fichier EXCEL.

J'ai créé un onglet "DATE" dans lequel je souhaite avoir le tracé de la frise. Pour cela, dans cet onglet, j'ai créé les deux boutons "effacer" et "tracer" chacun reliés à une macro (respectivement Effacer et Tracer).

Lorsque je clique sur effacer ---> tout s'efface y compris les boutons + impossible d'annuler l'action réalisée (undo et redo inactifs, boutons grisés) ?

Si je clique directement sur tracer voici ce que j'obtiens (voir fichier joint) : textes tronqués, ...

Des suggestions ?

Cdlt.
Jérôme.

**Theze** · 21/11/2018, 21h02

Comme tu peux voir dans la Sub Effacer(), il y a cette ligne de code :

Code :

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

1
2
 
If S.Name <> "BtnTracer" And S.Name <> "BtnEffacer" Then S.Delete

Cette ligne de code permet d'éviter de supprimer un bouton nommé "BtnTracer" et un autre nommé "BtnEffacer" donc, si tu veux que tes boutons ne soient pas supprimés, il te faut les nommer avec ces deux noms ou alors remplacer les noms dans le code.
Une fois que tu as posé les deux boutons sur ta feuille, dans la zone de Nom (à gauche de la barre de formules) écris BtnTracer et valide avec Entrée puis fais de même pour le second, tu n'as plusq qu'à tester, ils ne devrait plus disparaître !

Frise chronologique avec des dates.

Macros et VBA Excel

Discussions similaires

Partager

Partager