Suite de date automatique

**pilounet54** · 22/11/2013, 08h24

bonjour
je cherche à mettre la suite de date automatique depuis le 1 janvier jusqu'au 31 décembre 2013 en format date 01/01/2013.si a2<>"";si a3<> et la date serai en colonne D à partir row>1
je suis attentif a ce que vous pouvez me présenter si c'est en VBA bien sur c'est beaucoup mieux je vous laisse un peu de code vous inspirer

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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
 Private Sub Bouton_Français2_Click()
 
'Masquage du formulaire
Choix_Langue.Hide
 
'Réinitialisation
Cells.Value = Empty
Cells.Borders.LineStyle = xlNone
Cells.Font.ColorIndex = xlAutomatic
Cells.Font.Bold = False
Cells.VerticalAlignment = xlCenter
Cells.MergeCells = False
ActiveWindow.DisplayGridlines = True
 
Cells.Interior.ColorIndex = xlColorIndexNone          'rajout
 
 
'Liste personnelle
Application.AddCustomList ListArray:=Array("Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche")
 
'Mise en forme
'Range("A1:AJ1").HorizontalAlignment = xlCenterAcrossSelection
Range("A1").HorizontalAlignment = xlCenterAcrossSelection
Cells.Font.Size = 11
 
'Année
Dim Message, Titre, Année, Défaut
Message = "Entrez l'année"
Titre = "Année du calendrier"
Défaut = Year(Now)
Année = InputBox(Message, Titre, Défaut)
 
'En-tête
ActiveSheet.Name = Année
 
'Mois
Range("A1").Value = "Janvier"
Range("A33").Value = "Février"
Range("A65").Value = "Mars"
Range("A97").Value = "Avril"
Range("A129").Value = "Mai"
Range("A161").Value = "Juin"
Range("A193").Value = "Juillet"
Range("A225").Value = "Août"
Range("A257").Value = "Septembre"
Range("A289").Value = "Octobre"
Range("A321").Value = "Novembre"
Range("A353").Value = "Décembre"
 
'Dates
    'Mois en 31 jours
    For a = 1 To 31
    Range("B" & a + 1).Value = a
 
 
   'mars
    Range("B" & a + 65).Value = a
 
   'mai
    Range("B" & a + 129).Value = a
 
   'juillet
    Range("B" & a + 193).Value = a
    'aout
    Range("B" & a + 225).Value = a
    'octobre
    Range("B" & a + 289).Value = a
   'decembre
    Range("B" & a + 353).Value = a
    Next a
 
    'Mois en 30 jours
    For a = 1 To 30
    'avril
    Range("B" & a + 97).Value = a
    'juin
    Range("B" & a + 161).Value = a
    'septembre
    Range("B" & a + 257).Value = a
    'novembre
    Range("B" & a + 321).Value = a
    Next a
 
    'Février
    For a = 1 To 28
    Range("B" & a + 33).Value = a
    Next a
    On Error Resume Next
    Weekday ("29/02/" & Année)
    If Err.Number = 13 Then Err.Clear: Range("B62").Value = Empty Else Range("B62").Value = 29
 
'Jours
    'Janvier
    Jour = Weekday("01/01/" & Année)
    If Jour = 2 Then Journée = "Lundi"
    If Jour = 3 Then Journée = "Mardi"
    If Jour = 4 Then Journée = "Mercredi"
    If Jour = 5 Then Journée = "Jeudi"
    If Jour = 6 Then Journée = "Vendredi"
    If Jour = 7 Then Journée = "Samedi"
    If Jour = 1 Then Journée = "Dimanche"
    Range("A2").Value = Journée
    Range("A2").AutoFill Destination:=Range("A2:A32")
    'Février
 
    Range("A34").Value = Range("A26").Value
    If Range("A62").Value = Empty Then Range("A34").AutoFill Destination:=Range("A34:A61") Else Range("A34").AutoFill Destination:=Range("A34:A62")
 
    'Mars
    If Range("B62").Value = Empty Then Range("A66").Value = Range("A55").Value Else Range("A66").Value = Range("A55").Value
    Range("A66").AutoFill Destination:=Range("A66:A96")
 
    'Avril
    Range("A98").Value = Range("A58").Value
    Range("A98").AutoFill Destination:=Range("A98:A127")
 
    'Mai
    Range("A130").Value = Range("A121").Value
    Range("A130").AutoFill Destination:=Range("A130:A160")
 
    'Juin
    Range("A162").Value = Range("A154").Value
    Range("A162").AutoFill Destination:=Range("A162:A191")
 
    'Juillet
    Range("A194").Value = Range("A185").Value
    Range("A194").AutoFill Destination:=Range("A194:A224")
 
    'Août
    Range("A226").Value = Range("A218").Value
    Range("A226").AutoFill Destination:=Range("A226:A256")
 
    'Septembre
    Range("A258").Value = Range("A250").Value
    Range("A258").AutoFill Destination:=Range("A258:A287")
 
    'Octobre
    Range("A290").Value = Range("A281").Value
    Range("A290").AutoFill Destination:=Range("A290:A320")
 
    'Novembre
    Range("A322").Value = Range("A314").Value
    Range("A322").AutoFill Destination:=Range("A322:A351")
 
    'Décembre
    Range("A354").Value = Range("A345").Value
    Range("A354").AutoFill Destination:=Range("A354:A384")
 
'Semaines
b = 1
For Mois = 1 To 36 Step 3
For a = 2 To 384
If Cells(a, Mois).Value = "Lundi" Then Cells(a, Mois + 2).Value = b: b = b + 1
Next a
Next Mois
 
'Mise en page
    'Grille
    ActiveWindow.DisplayGridlines = False
    With Range("A1:B384").Borders
        .LineStyle = xlContinuous
        .ColorIndex = 1 ''''''''''''''''''''''''''''''''''''''''' couleur total grille
    End With
    ActiveWindow.DisplayGridlines = False
    With Range("D1:AZ384").Borders
        .LineStyle = xlContinuous
        .ColorIndex = 1 ''''''''''''''''''''''''''''''''''''''''' couleur total grille
    End With
 
 
 
    Range("A1:AZ384").Borders(xlEdgeLeft).Weight = xlThick ''''' barre
    Range("A1:AZ384").Borders(xlEdgeTop).Weight = xlThick    ''' barre
    Range("A1:AZ384").Borders(xlEdgeBottom).Weight = xlThick ''' barre
    Range("A1:AZ384").Borders(xlEdgeRight).Weight = xlThick '''' barre
    Range("A1:AZ384").Borders(xlEdgeLeft).ColorIndex = 5 ''''''''barre de gauche
    Range("A1:AZ384").Borders(xlEdgeTop).ColorIndex = 5 '''''''''barre du haut
    Range("A1:AZ384").Borders(xlEdgeBottom).ColorIndex = 5 ''''''barre du bas
    Range("A1:AZ384").Borders(xlEdgeRight).ColorIndex = 5  ''''''barre de droite
    Range("A1:AZ384").Font.Bold = True
 
 
    'Semaines
    b = 1
    For Mois = 1 To 36 Step 3
    For a = 2 To 384
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Cells(a, Mois).Value = "Lundi" Then Cells(a, Mois + 2).Value = b: b = b + 1
    If Cells(a, Mois).Value = "Lundi" Then If a = 2 Then GoTo FinDeBoucle Else Range(Cells(a, Mois), Cells(a, Mois + 51)).Borders(xlEdgeTop).Weight = xlMedium: Range(Cells(a, Mois), Cells(a, Mois + 51)).Borders(xlEdgeTop).ColorIndex = 5 '''couleur bas cellulle dimanche
 
    If Cells(a, Mois).Value = "Dimanche" Then Cells(a, Mois).Font.ColorIndex = 5 '''couleur du dimanche
    If Cells(a, Mois).Value = "Dimanche" Then Cells(a, Mois + 1).Font.ColorIndex = 5 '''chiffre du dimanche
 
    If Cells(a, Mois).Value = "Lundi" Then If a = 4 Then Range(Cells(a - 2, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 5 Then Range(Cells(a - 3, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 6 Then Range(Cells(a - 4, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 7 Then Range(Cells(a - 5, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 8 Then Range(Cells(a - 6, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 9 Then Range(Cells(a - 7, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
 
    If Cells(a, Mois + 2).Value = Empty Then GoTo FinDeBoucle
 
    If Cells(a, Mois + 2).Row <= 26 Then Range(Cells(a, Mois + 2), Cells(a + 6, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 27 Then Range(Cells(a, Mois + 2), Cells(a + 5, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 28 Then Range(Cells(a, Mois + 2), Cells(a + 4, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 29 Then Range(Cells(a, Mois + 2), Cells(a + 3, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 30 Then Range(Cells(a, Mois + 2), Cells(a + 2, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 31 Then Range(Cells(a, Mois + 2), Cells(a + 1, Mois + 2)).Cells.MergeCells = True
FinDeBoucle: Next a
    Next Mois
 
    Range("C:C,C:C,I:I,L:L,O:O,R:R,U:U,X:X,AA:AA,AD:AD,AG:AG,AJ:AJ").Font.Bold = True
 
    'Fermeture du formulaire
    Unload Choix_Langue
 
End Sub

cordialement

**Daniel.C** · 22/11/2013, 10h56

Bonjour Patrick,

Qu'est-ce qui ne va pas avec ta macro ? A part la colonne C - je ne sais pas ce que tu veux y mettre - le résultat a l'air correct.

**pilounet54** · 22/11/2013, 12h23

oui le résultat est très correcte mais j'ai besoin incrémenter la date en format

01/01/2013 à partir de la ligne de 2 de la colonne C

es-ce possible merci

**Daniel.C** · 22/11/2013, 12h33

Là, je ne comprends pas trop; est-ce que tu peux donner ce que tu souhaites pour quelques lignes ?

**pilounet54** · 22/11/2013, 14h36

bonjour il faut bien imaginer que la feuille ce crée tout seule pour le coup
et avec simplement l'année dans un imputbox
il faut aussi imaginer que je passe d'une année à l'autre sur plusieurs année donc même problème
pour mettre les dates automatiquement car j'en ai besoin
donc comment on pourrai faire svp dans la colonne D row>1 pour que la date d’après ce que vous voyez ce mets automatiquement es possible
cordialement
si a2<>"" résultat en D2 01/01/2013 "2013 c'est aussi la date de l'onglet "
si a3<>"" résultat en D3 02/01/2013 et ainsi de suite
cordialement et merci encore d'essayer de comprendre

**Daniel.C** · 22/11/2013, 15h20

J'ai ajouté la macro "Dates" avant la mise en forme.

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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
 Private Sub Bouton_Français2_Click()
 
'Masquage du formulaire
'Choix_Langue.Hide
 
'Réinitialisation
Cells.Value = Empty
Cells.Borders.LineStyle = xlNone
Cells.Font.ColorIndex = xlAutomatic
Cells.Font.Bold = False
Cells.VerticalAlignment = xlCenter
Cells.MergeCells = False
ActiveWindow.DisplayGridlines = True
 
Cells.Interior.ColorIndex = xlColorIndexNone          'rajout
 
 
'Liste personnelle
Application.AddCustomList ListArray:=Array("Lundi", "Mardi", "Mercredi", "Jeudi", "Vendredi", "Samedi", "Dimanche")
 
'Mise en forme
'Range("A1:AJ1").HorizontalAlignment = xlCenterAcrossSelection
Range("A1").HorizontalAlignment = xlCenterAcrossSelection
Cells.Font.Size = 11
 
'Année
Dim Message, Titre, Année, Défaut
Message = "Entrez l'année"
Titre = "Année du calendrier"
Défaut = Year(Now)
Année = InputBox(Message, Titre, Défaut)
 
'En-tête
ActiveSheet.Name = Année
 
'Mois
Range("A1").Value = "Janvier"
Range("A33").Value = "Février"
Range("A65").Value = "Mars"
Range("A97").Value = "Avril"
Range("A129").Value = "Mai"
Range("A161").Value = "Juin"
Range("A193").Value = "Juillet"
Range("A225").Value = "Août"
Range("A257").Value = "Septembre"
Range("A289").Value = "Octobre"
Range("A321").Value = "Novembre"
Range("A353").Value = "Décembre"
 
'Dates
    'Mois en 31 jours
    For a = 1 To 31
    Range("B" & a + 1).Value = a
 
 
   'mars
    Range("B" & a + 65).Value = a
 
   'mai
    Range("B" & a + 129).Value = a
 
   'juillet
    Range("B" & a + 193).Value = a
    'aout
    Range("B" & a + 225).Value = a
    'octobre
    Range("B" & a + 289).Value = a
   'decembre
    Range("B" & a + 353).Value = a
    Next a
 
    'Mois en 30 jours
    For a = 1 To 30
    'avril
    Range("B" & a + 97).Value = a
    'juin
    Range("B" & a + 161).Value = a
    'septembre
    Range("B" & a + 257).Value = a
    'novembre
    Range("B" & a + 321).Value = a
    Next a
 
    'Février
    For a = 1 To 28
    Range("B" & a + 33).Value = a
    Next a
    On Error Resume Next
    Weekday ("29/02/" & Année)
    If Err.Number = 13 Then Err.Clear: Range("B62").Value = Empty Else Range("B62").Value = 29
 
'Jours
    'Janvier
    Jour = Weekday("01/01/" & Année)
    If Jour = 2 Then Journée = "Lundi"
    If Jour = 3 Then Journée = "Mardi"
    If Jour = 4 Then Journée = "Mercredi"
    If Jour = 5 Then Journée = "Jeudi"
    If Jour = 6 Then Journée = "Vendredi"
    If Jour = 7 Then Journée = "Samedi"
    If Jour = 1 Then Journée = "Dimanche"
    Range("A2").Value = Journée
    Range("A2").AutoFill Destination:=Range("A2:A32")
    'Février
 
    Range("A34").Value = Range("A26").Value
    If Range("A62").Value = Empty Then Range("A34").AutoFill Destination:=Range("A34:A61") Else Range("A34").AutoFill Destination:=Range("A34:A62")
 
    'Mars
    If Range("B62").Value = Empty Then Range("A66").Value = Range("A55").Value Else Range("A66").Value = Range("A55").Value
    Range("A66").AutoFill Destination:=Range("A66:A96")
 
    'Avril
    Range("A98").Value = Range("A58").Value
    Range("A98").AutoFill Destination:=Range("A98:A127")
 
    'Mai
    Range("A130").Value = Range("A121").Value
    Range("A130").AutoFill Destination:=Range("A130:A160")
 
    'Juin
    Range("A162").Value = Range("A154").Value
    Range("A162").AutoFill Destination:=Range("A162:A191")
 
    'Juillet
    Range("A194").Value = Range("A185").Value
    Range("A194").AutoFill Destination:=Range("A194:A224")
 
    'Août
    Range("A226").Value = Range("A218").Value
    Range("A226").AutoFill Destination:=Range("A226:A256")
 
    'Septembre
    Range("A258").Value = Range("A250").Value
    Range("A258").AutoFill Destination:=Range("A258:A287")
 
    'Octobre
    Range("A290").Value = Range("A281").Value
    Range("A290").AutoFill Destination:=Range("A290:A320")
 
    'Novembre
    Range("A322").Value = Range("A314").Value
    Range("A322").AutoFill Destination:=Range("A322:A351")
 
    'Décembre
    Range("A354").Value = Range("A345").Value
    Range("A354").AutoFill Destination:=Range("A354:A384")
 
'Semaines
b = 1
For Mois = 1 To 36 Step 3
For a = 2 To 384
If Cells(a, Mois).Value = "Lundi" Then Cells(a, Mois + 2).Value = b: b = b + 1
Next a
Next Mois
Dates CInt(Année)
'Mise en page
    'Grille
    ActiveWindow.DisplayGridlines = False
    With Range("A1:B384").Borders
        .LineStyle = xlContinuous
        .ColorIndex = 1 ''''''''''''''''''''''''''''''''''''''''' couleur total grille
    End With
    ActiveWindow.DisplayGridlines = False
    With Range("D1:AZ384").Borders
        .LineStyle = xlContinuous
        .ColorIndex = 1 ''''''''''''''''''''''''''''''''''''''''' couleur total grille
    End With
 
 
 
    Range("A1:AZ384").Borders(xlEdgeLeft).Weight = xlThick ''''' barre
    Range("A1:AZ384").Borders(xlEdgeTop).Weight = xlThick    ''' barre
    Range("A1:AZ384").Borders(xlEdgeBottom).Weight = xlThick ''' barre
    Range("A1:AZ384").Borders(xlEdgeRight).Weight = xlThick '''' barre
    Range("A1:AZ384").Borders(xlEdgeLeft).ColorIndex = 5 ''''''''barre de gauche
    Range("A1:AZ384").Borders(xlEdgeTop).ColorIndex = 5 '''''''''barre du haut
    Range("A1:AZ384").Borders(xlEdgeBottom).ColorIndex = 5 ''''''barre du bas
    Range("A1:AZ384").Borders(xlEdgeRight).ColorIndex = 5  ''''''barre de droite
    Range("A1:AZ384").Font.Bold = True
 
 
    'Semaines
    b = 1
    For Mois = 1 To 36 Step 3
    For a = 2 To 384
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Cells(a, Mois).Value = "Lundi" Then Cells(a, Mois + 2).Value = b: b = b + 1
    If Cells(a, Mois).Value = "Lundi" Then If a = 2 Then GoTo FinDeBoucle Else Range(Cells(a, Mois), Cells(a, Mois + 51)).Borders(xlEdgeTop).Weight = xlMedium: Range(Cells(a, Mois), Cells(a, Mois + 51)).Borders(xlEdgeTop).ColorIndex = 5 '''couleur bas cellulle dimanche
 
    If Cells(a, Mois).Value = "Dimanche" Then Cells(a, Mois).Font.ColorIndex = 5 '''couleur du dimanche
    If Cells(a, Mois).Value = "Dimanche" Then Cells(a, Mois + 1).Font.ColorIndex = 5 '''chiffre du dimanche
 
    If Cells(a, Mois).Value = "Lundi" Then If a = 4 Then Range(Cells(a - 2, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 5 Then Range(Cells(a - 3, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 6 Then Range(Cells(a - 4, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 7 Then Range(Cells(a - 5, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 8 Then Range(Cells(a - 6, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois).Value = "Lundi" Then If a = 9 Then Range(Cells(a - 7, Mois + 2), Cells(a - 1, Mois + 2)).Cells.MergeCells = True
 
    If Cells(a, Mois + 2).Value = Empty Then GoTo FinDeBoucle
 
    If Cells(a, Mois + 2).Row <= 26 Then Range(Cells(a, Mois + 2), Cells(a + 6, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 27 Then Range(Cells(a, Mois + 2), Cells(a + 5, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 28 Then Range(Cells(a, Mois + 2), Cells(a + 4, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 29 Then Range(Cells(a, Mois + 2), Cells(a + 3, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 30 Then Range(Cells(a, Mois + 2), Cells(a + 2, Mois + 2)).Cells.MergeCells = True
    If Cells(a, Mois + 2).Row = 31 Then Range(Cells(a, Mois + 2), Cells(a + 1, Mois + 2)).Cells.MergeCells = True
FinDeBoucle: Next a
    Next Mois
 
    Range("C:C,C:C,I:I,L:L,O:O,R:R,U:U,X:X,AA:AA,AD:AD,AG:AG,AJ:AJ").Font.Bold = True
 
    'Fermeture du formulaire
    Unload Choix_Langue
 
End Sub
Sub Dates(Année)
    Dim Ligne As Integer
    Ligne = Cells(Rows.Count, 1).End(xlUp).Row
    [D2] = DateSerial(Année, 1, 1)
    [D2].AutoFill Range("D2:D" & Ligne)
End Sub

Suite de date automatique

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager