Discussion :

[apt]

Bonjour à tous,

J'aimerais avoir autant de fractions possibles pour des périodes globale définies par une date de début et une de fin.

Ce fractionnement repose sur les dates de périodes saisies entre temps dans le tableau.

Si par exemple, j'ai dans mon tableau les dates suivantes :

sss R 09/08/2013 19/08/2013
sss F 17/08/2013 17/08/2013

Alors, la date globale :

sss R 09/08/2013 19/08/2013

sera fractionnée selon la période suivante :

sss F 17/08/2013 17/08/2013

Pour avoir :

sss R 09/08/2013 16/08/2013
sss F 17/08/2013 17/08/2013
sss R 18/08/2013 19/08/2013

Mais voila, certain lignes sont correctes, d'autres ne le sont pas comme ceci :

sss L 20/08/2013 16/08/2013

Voila, le code que j'utilise :

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
Sub FractionDate()
'
' Fractionner une date selon des periodes
'
 
    Dim LastLg As Integer, FinTraitement As Boolean
    Dim Ligne As Integer, Lg As Integer, L As Integer
 
    Application.ScreenUpdating = False
    With Sheets("Données")
        LastLg = Range("A10000").End(xlUp).Row
        '-- Tri selon les noms + date de début
        .Range(.Range("A2"), .Cells(LastLg, "D")).Sort key1:=.Range("A2"), order1:=xlAscending, _
                                                       key2:=.Range("C2"), order2:=xlAscending, Header:=xlNo, _
                                                       dataoption1:=xlSortNormal, dataoption2:=xlSortNormal
 
        Lg = 1 ' Au moins la ligne des titres
        Do
 
            If Not FinTraitement Then
                '-- Trouver la dernière ligne
                LastLg = Range("A10000").End(xlUp).Row
                L = Lg + 1
                MsgBox "Boucle de " & L & " à " & LastLg
                For Lg = L To LastLg    'Ligne
                    '                        MsgBox "Ligne " & Lg & ", Fin : " & .Range("D" & Lg) & ", Début : " & .Range("C" & Lg + 1)
 
                    If .Range("D" & Lg) > .Range("C" & Lg + 1) Then
                        Debug.Print "Fin : " & .Range("D" & Lg) & ", Début : " & .Range("C" & Lg + 1)
 
                        '-- Copier la ligne en cours
                        .Range("A" & Lg & ":D" & Lg).Copy
 
                        '-- La faire coller apres 2 lignes
                        .Range("A" & Lg + 2 & ":D" & Lg + 2).Insert Shift:=xlDown
 
                        '-- La date de début de la nouvelle ligne ajoutée sera égal à la date
                        '-- de fin de la ligne en Lg + 1
                        .Range("C" & Lg + 2) = .Range("D" & Lg + 1) + 1
 
 
                        '-- La date fin de la nouvelle ligne ajoutée sera égal à la date
                        '-- de début de la ligne Lg 'colonne D en cours
                        .Range("D" & Lg + 2) = .Range("D" & Lg)
 
                        '-- La date de fin en cours sera modifiée pour celle
                        '-- de la date de début de la ligne Lg + 1, -1
                        .Range("D" & Lg) = .Range("C" & Lg + 1) - 1
 
                        With .Range("A" & Lg & ":D" & Lg)
                            If .Interior.Pattern = xlNone Then
                                '-- Couleur jaune pour une ligne modifiée
                                .Interior.Color = RGB(255, 255, 0)    '6
                            End If
                        End With
 
                        '-- Couleur bleu pour une ligne ajoutée
                        .Range("A" & Lg + 2 & ":D" & Lg + 2).Interior.Color = RGB(219, 229, 241)    '34
                    End If
                Next Lg
            End If
            Ligne = Lg - 1
            LastLg = .Range("A10000").End(xlUp).Row
            '            MsgBox "Ligne For s'est arreté à : " & Lg & vbCrLf & _
                         "Ligne tableau en cours : " & LastLg
            If Lg >= LastLg - 1 Then FinTraitement = True
        Loop Until FinTraitement    'Ligne
        Application.CutCopyMode = False
 
        '-- Tri selon les noms + date de début
        .Range(.Range("A2"), .Cells(LastLg, "D")).Sort key1:=.Range("A2"), order1:=xlAscending, _
                                                       key2:=.Range("C2"), order2:=xlAscending, Header:=xlNo, _
                                                       dataoption1:=xlSortNormal, dataoption2:=xlSortNormal
 
    End With
End Sub

Merci d'avance.

[nibledispo]

Bonjour,

Pour corriger fin < debut faire en début de procédure cela:

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
 
 Dim LastLg As Integer, FinTraitement As Boolean
 Dim Ligne As Integer, Lg As Integer, L As Integer
 
 Application.ScreenUpdating = True  'False
 
 With Sheets("Données")
        LastLg = Range("A10000").End(xlUp).Row
 
        For Lg = 2 To LastLg
           If Cells(L, 3) > Cells(L, 4) Then
              Change = Cells(L, 3)
              Cells(L, 3) = Cells(L, 4)
              Cells(L, 4) = Change
           End If
        Next Lg

Par alleurs, il est surement préférable de faire ensuite le trie prioritairement sur la date début et non pas sur le nom.

L ne sert à rien, faire directement dans la suite du code :

Code :

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

1
2
 
for Lg = 2 to lastlg

Je n'ai pas regarder la suite du code. Bon courage.

[Theze]

Bonjour,

Je ne me suis pas penché sur ton code mais je pense qu'il serait mieux de faire une fonction de fractionnement, ça serait plus clair. Je te poste un petit exemple que tu pourra adapter si le coeur t'en dit :

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
 
Sub Test()
 
    Dim Tbl() As String
    Dim Resultat As String
    Dim I As Integer
 
    'appel de la fonction avec passage des arguments String
    '(ça peut être des valeurs de cellules)
    'comme par exemple : Tbl = Fraction(Range("A1"), Range("B1"))
    Tbl = Fraction("sss R 09/08/2013 19/08/2013", "sss F 17/08/2013 17/08/2013")
 
    'ici le résultat du fractionnement est récupéré par concaténation dans une variable
    'mais il peut être dispatché dans des cellules
    For I = 1 To UBound(Tbl)
 
        Resultat = Resultat & Tbl(I) & vbCrLf
 
    Next I
 
    MsgBox Resultat
    'ou :
    Debug.Print Resultat
 
End Sub
 
Function Fraction(Globale As String, Periode As String) As String()
 
    Dim TblDate(1 To 3) As String
    Dim DateFinGlob As String
    Dim DateDebutPer As String
    Dim DateFinPer As String
 
    DateFinGlob = Split(Globale, " ")(3)
    DateDebutPer = Split(Periode, " ")(2)
    DateFinPer = Split(Periode, " ")(3)
 
    TblDate(1) = Left(Globale, InStr(Globale, DateFinGlob) - 1) & CDate(DateDebutPer) - 1
    TblDate(2) = Periode
    TblDate(3) = Left(Globale, 6) & CDate(DateFinPer) + 1 & " " & DateFinGlob
 
    Fraction = TblDate
 
End Function

Hervé.

[apt]

Bonjour nibledispo, Theze,

> nibledispo :: Au lieu de faire inverser les anomalies dans les dates, ne peut-on pas faire la bonne insertion dés le début du traitement ?

> Theze :: Les propositions sont les bienvenues

Mais, dans ce cas, il faut au préalable définir les plages qui seront fractionner, non ?

[Theze]

Re,

Un exemple. Les périodes globales sont en colonne "A", les périodes à intégrées sont en colonne "B" et elles sont sensées être logiques, c'est à dire qu'elles sont bien entre les bornes de la période globale. Le résultat est inscrit en colonne "C", "D" et "E". Fait un test sur un classeur vierge en entrant les périodes globales en colonne "A" et les périodes à intégrer correspondantes en colonne "B" puis lance la proc "Test" :

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
 
Sub Test()
 
    Dim Plage As Range
    Dim Cel As Range
    Dim Tbl() As String
 
    'défini la plage sur la colonne "A" de la feuille "Feuil1"
    With Worksheets("Feuil1")
 
        Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
    'boucle sur toutes les cellules de la plage
    For Each Cel In Plage
 
        'passe en argument la cellule de la colonne "A" qui est la période globale
        'et la cellule d'à coté (colonne "B") qui est la période à intégrée dans la période globale
        Tbl = Fraction(Cel.Value, Cel.Offset(, 1).Value)
 
        'le résultat du fractionnement est inscrit en colonne "C", "D" et "E"
        Cel.Offset(0, 2).Value = Tbl(1)
        Cel.Offset(0, 3).Value = Tbl(2)
        Cel.Offset(0, 4).Value = Tbl(3)
 
    Next Cel
 
End Sub
 
Function Fraction(Globale As String, Periode As String) As String()
 
    Dim TblDate(1 To 3) As String
    Dim DateFinGlob As String
    Dim DateDebutPer As String
    Dim DateFinPer As String
 
    DateFinGlob = Split(Globale, " ")(3)
    DateDebutPer = Split(Periode, " ")(2)
    DateFinPer = Split(Periode, " ")(3)
 
    TblDate(1) = Left(Globale, InStr(Globale, DateFinGlob) - 1) & CDate(DateDebutPer) - 1
    TblDate(2) = Periode
    TblDate(3) = Left(Globale, 6) & CDate(DateFinPer) + 1 & " " & DateFinGlob
 
    Fraction = TblDate
 
End Function

Hervé.

[apt]

Bonsoir Theze,

La fonction fait bien son travail pour le moment.

Mais comme les dates sont saisies au fur et à mesure qu'on aura besoin, et parfois des dates se croisent pour le mois précédent ou le mois suivant, on ne peut déterminer au début du mois quelles dates seront fractionnées.

Par exemple :

La période du 09/08/2013 au 19/08/2013 fractionnera la période globale du 01/08/2013 au 31/08/2013.

D’autre coté, cette même période deviendra à son tour une période globale, quand elle sera fractionnée par la période :

Du 17/08/2013 au 17/08/2013

Alors, en PJ, une conception de données, à traiter !

[nibledispo]

Bonjour apt,

J'ai tenté de trouver une solution à ton problème mais en vain.

J'espère qu'un autre parviendra à le solutionner car pour l'heure les codes proposés ne règlent pas le problème.

Le passage par les tableaux - code qui se trouve sur ton fichier et proposé par je ne sais qui en dehors du site- me semble un bonne approche.

Je me demande si le tri sur les dates de départ ne pose pas problème.

je persévère mais sans trop d'illusion.

Peut-être un membre automaticien pourra-t-il résoudre ton problème au contraintes multiples.

bon courage.

[Marc-L]

Voir aussi Split a date according to periods …

[nibledispo]

Bonsoir MARC,

Peut-être me suis-je créé des contraintes non demandées.

APT voulant extraire un résultat sur un mois donné j'ai pensé qu'une donnée du genre :

SSS R 10/02/2013 25/03/2013
SSS Rf 02/03/2013 20/03/2013

devait restituer ceci pour un mois 3 complet
R 10/02/2013 28/02/2013 ...... mois 2
R 01/03/2013 01/03/2013 ...... mois 3
Rf 02/03/2013 20/03/2013
R 21/03/2013 25/03/2013

en tout cas ton code que j'ai étudié m'a permis de constater qu faux en VBA valait "-1" alors que sur le tableur il vaut "0". chose confirmée par un document trouvé sur le net après bien du temps passé.

je ne comprend pas l'Anglais mais il m'a bien semblé que le code est à quelques nuances près le même que celui remis sur DVP.

cordialement.

[Marc-L]

en tout cas ton code que j'ai étudié m'a permis de constater qu faux en VBA valait "-1" alors que sur le tableur il vaut "0".

Niet ‼

En VBA comme depuis le BASIC, Faux vaut zéro et Vrai -1 !

Pour t'en convaincre : Debug.Print False * 1, True * 1 …

[nibledispo]

Bonjour,

Exacte, je me suis mélangé les pinceaux en tapant le message. Comme quoi, ce n'est pas encore bien assimilé. Enfin, maintenant je connais la méthode pour me rafraichir la mémoire qui est bien défaillante.

[apt]

Bonjour nibledispo,

Peut-être me suis-je créé des contraintes non demandées.

APT voulant extraire un résultat sur un mois donné j'ai pensé qu'une donnée du genre :

SSS R 10/02/2013 25/03/2013
SSS Rf 02/03/2013 20/03/2013

devait restituer ceci pour un mois 3 complet
R 10/02/2013 28/02/2013 ...... mois 2
R 01/03/2013 01/03/2013 ...... mois 3
Rf 02/03/2013 20/03/2013
R 21/03/2013 25/03/2013

Comme les périodes saisies sont des données à traiter, le code qui fait le traitement de réorganisation des périodes selon chaque mois à part, n'est appliqué qu’en d'autres étapes qui suivent lors de remplissage de mon planning de présence.

[nibledispo]

Bonjour APT,

Je n'ai pas compris ta réponse.

Doit-on , oui ou non, en début de mois ou fin de mois fractionner une donnée du genre.

SSS R 10/02/2013 25/03/2013

afin d'avoir des mois représentatifs de la réalité.

Faute de ce découpage un mois se retrouve avec un nombre de jours supérieur au nombre de jours travaillés et l'autre, est déficitaire.

Par ailleurs, la solution de MARC, qui est une approche intéressante, ne répond que partiellement au problème. On se retrouve parfois avec un chevauchement des dates.

Le problème ne doit pas être si simple au vu du nombre de réponses apportées à ce jour.

Cordialement.

[apt]

Bonjour nibledispo,

Doit-on , oui ou non, en début de mois ou fin de mois fractionner une donnée du genre.

SSS R 10/02/2013 25/03/2013

afin d'avoir des mois représentatifs de la réalité..

La réponse est oui, s’il y a une période contenue dans cette période initiale.

Comme ton exemple :

SSS - R - 10/02/2013 - 25/03/2013
SSS - Rf - 02/03/2013 - 20/03/2013

On aura :

SSS – R - 10/02/2013 - 01/03/2013
SSS – Rf - 02/03/2013 - 20/03/2013
SSS – R - 21/03/2013 - 25/03/2013

Faute de ce découpage un mois se retrouve avec un nombre de jours supérieur au nombre de jours travaillés et l'autre, est déficitaire.

Tu as raison, mais comme j'ai avancé, lors du remplissage de mon planning (J'ai déjà le code qui fait cela), je devrais ne laisser que des dates représentants le mois en cours du traitement

[nibledispo]

Bonjour,

C'est bien ce qu'il me semblait avoir compris et redoutais bien que logique.
C'est sans doute le point le plus délicat à résoudre qui appelle une réponse différente selon les paramètres suivants :

datedebut datefin
>= >=
>= <=
<= <=

Si tu as le code qui fait cela, je serais heureux (et d'autres avec moi peut-être) de le connaitre afin de le comparer les approches.

En résumé (pour ceux qui prendraient la discussion à ce stade), le traitement doit:

- distinguer les agents (reprise de la chronologie à chaque changement d'agent)

Pour un agent donné :
- se limiter strictement au mois en question.
(sur ton exemple, ce ne peut donc être date fin 01/03 mais 31/02)
- ne pas avoir de chevauchement des périodes d'activité (ce qui se passe dans certains cas avec le code de MARC) .
- en cas de période repos (R) compensatoire, ne pas tomber un jour férié.
- colorier Les lignes fractionnées en jaune et celles ajoutées en bleu.

On n'est pas sortie de l'auberge.

cordialement.

[nibledispo]

Bonsoir Apt,

je ne t'avais pas oublié mais force est de reconnaitre que je ne suis parvenu a aucune solution satisfaisante. Il faudrait pour cela un membre maitrisant toutes les possibilités de VBA conjugué à une capacité d'analyse certaine. ce qui n'est pas mon cas.

je regarde cependant si la nouvelle donne simplifie réellement les choses.

Cordialement.

[apt]

Bonjour Paul,

Merci d’être penché sur mon problème

Il faudrait pour cela un membre maitrisant toutes les possibilités de VBA conjugué à une capacité d'analyse certaine

Je suis entièrement d'accord avec toi

[apt]

Bonjour,

Après plusieurs tentatives, me revoilà avec un nouveau code avec lequel j'ai pu arrivé à un résultat pour cet exemple :


Données initiales :



Résultat obtenu :




Le code nécessite encore des correctifs et devra être tester avec d'autres cas de figures.

Procédure principale :

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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
Option Explicit
 
'-----------------------------------------------------------------
Public A As Long, Lc As Long, Rcp As Long
Public Dd(), Df()
 
Sub FracCompDate()
'Il faut ajouter la référence "Microsoft Scripting Runtime"
'Barre des menus / outils / références /
 
    Dim DateDebut As Range, DateFin As Range, C As Range, Plg As Range
    Dim Td(), Tf(), Tc(), Tsys(), Tnj(), TRc(), Ts(), X As Variant
    Dim B As Long, A As Long, Mois As Long, Rg As Range
    Dim Dic As Scripting.Dictionary, G As Long, Madate As Variant
    Dim LD As Long, LF As Long, Nom As String, Dtd As Variant
    Dim NbLignes As Long, M As Date, S As Long, Sh As Worksheet
    Dim Rcp1 As Long, Rcp2 As Long
    Dim Max As Long, Cl As Long, Rcp As Long
    Dim Couleur As Long
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    Mois = 8    'Date du mois à traiter
 
    Set Sh = Worksheets("Données")    'Nom feuille à adapter
 
    Set Dic = CreateObject("scripting.dictionary")
 
    '--
    Range(Range("A" & Range("A1").End(xlDown).Row + 2), Range("G100")).Clear
    '--
 
    'Recenser les noms différents et mettre dans
    'la variable dictionnaire.
    With Sh
        For Each C In .Range("A2:A" & .Range("A100").End(xlUp).Row)
            If Not Dic.exists(C.Value) Then
                Dic.Add C.Value, A
            End If
        Next
    End With
 
    For G = 0 To Dic.Count - 1
        Nom = Dic.Keys(G)
 
        '-- Recherche de la plage occupé par NOM
        With Sh
            With .Range("A1:A" & .Range("A17").End(xlUp).Row)
                'Ligne du début
                LD = .Find(What:=Nom, LookIn:=xlValues, lookAt:=xlWhole, searchdirection:=xlNext).Row
                'Ligne du fin
                LF = .Find(What:=Nom, LookIn:=xlValues, lookAt:=xlWhole, searchdirection:=xlPrevious).Row
            End With
 
            '-- Trier la plage sur la colonne Début
            With .Range("A" & LD & ":G" & LF)
                .Sort Key1:=.Item(1, 5), order1:=xlAscending, Header:=xlNo
            End With
 
            '-- Plage pour les dates du début
            Set DateDebut = .Range("E" & LD & ":E" & LF)
 
            '-- Plage pour les dates de fin
            Set DateFin = .Range("F" & LD & ":F" & LF)
 
            '-- Nombre de lignes de la plage
            NbLignes = DateDebut.Cells.Count
 
            '            If NbLignes < 2 Then Exit Sub
        End With
 
        A = 1: Cl = S + 2
        Do Until A > NbLignes
            B = B + 1
            ReDim Preserve Td(1 To B)
            ReDim Preserve Tf(1 To B)
            ReDim Preserve Ts(1 To B)
            ReDim Preserve Tsys(1 To B)
            ReDim Preserve Tc(1 To B)
            ReDim Preserve Tnj(1 To B)
            ReDim Preserve TRc(1 To B)
 
            '-- Si ce n'est pas le mois en cours
            If Month(DateDebut(A)) <> Mois And Month(DateFin(A)) <> Mois Then
                MsgBox "Mois défirent de : " & Mois & vbCrLf & "Début : " & DateDebut(A) & " :: Fin : " & DateFin(A)
                Td(B) = CLng(DateDebut(A))          ' Date début
                Tf(B) = CLng(DateFin(A))            ' Date fin
                Tsys(B) = DateDebut(A).Offset(, -2)    ' Sous-Système
                Ts(B) = DateDebut(A).Offset(, -3)   ' Système
                Tnj(B) = DateDebut(A).Offset(, -1)  ' Nombre de jours ouvrés
 
                'Récupération de la couleur de la ligne
                Couleur = DateDebut(A).Interior.Color
 
                Select Case Couleur
                Case 65535: Tc(B) = "Jaune"
                Case 15853019: Tc(B) = "Bleu"
                Case 12379351: Tc(B) = "Vert"
                Case Else: Tc(B) = ""    '-4142
                End Select
 
 
                '-- Si c'est le mois en cours
            Else
                '-- Jours R initial à traiter
                MsgBox "Système actuel : " & DateDebut(A).Offset(, -2) & ", Ligne : " & A + 1
                If UCase(DateDebut(A).Offset(, -2)) = "R" Then Rcp = DateDebut(A).Offset(, -1)
 
                '-- supérieur
                If DateDebut(A + 1) > DateFin(A) Then
                    '-- Si la différence est plus d'un jour
                    If DateDebut(A + 1) - DateFin(A) > 1 Then
 
                        '1- Sauvegarde de la ligne en cours
                        Td(B) = CLng(DateDebut(A))
                        Tf(B) = CLng(DateFin(A))
                        Tsys(B) = DateDebut(A).Offset(, -2)
                        Tc(B) = ""
                        If Tsys(B) = "R" Then
                            Tnj(B) = NBJOuvres(Td(B), Tf(B))
                            If Range("H" & A + 1) = "v" Then Tc(B) = "Vert"
                        Else
                            Tnj(B) = "": Tc(B) = ""
                        End If
                        Ts(B) = DateDebut(A).Offset(, -3)
 
                        '-- Ajouter une ligne
 
                        If Tsys(B) <> "R" Or Tnj(B) = Rcp Then
 
                            '2 - Créer une nouvelle ligne en bleu
                            B = B + 1
                            ReDim Preserve Td(1 To B)
                            ReDim Preserve Tf(1 To B)
                            ReDim Preserve Ts(1 To B)
                            ReDim Preserve Tsys(1 To B)
                            ReDim Preserve Tc(1 To B)
                            ReDim Preserve Tnj(1 To B)
 
                            Td(B) = CLng(DateFin(A) + 1)
 
                            '-- Recerche du système qui correspond à la date max
                            '-- dans les dates de fin
                            Set Rg = Range(Sh.Name & "!" & Range(DateFin(1, 1).Address & ":" & DateFin(A, 1).Address).Address)
                            M = Application.Max(Rg)
 
                            '-- test on est arrivé à la fin des lignes traités
                            If A = NbLignes Then
                                Tf(B) = M
                            Else
                                Tf(B) = CLng(DateDebut(A + 1) - 1)
                            End If
 
                            If Td(B) < CLng(M) Then
                                Dtd = Application.Match(CLng(M), DateFin, 0)
                                If IsNumeric(Dtd) And DateDebut(Dtd).Offset(, -2) <> "R" Then
                                    MsgBox "Système : " & Tsys(B) & vbCrLf & "Correspond à : " & DateDebut(Dtd).Offset(, -2)
                                    Tsys(B) = DateDebut(Dtd).Offset(, -2)
                                    If Tsys(B) = "R" Then
                                        Tnj(B) = NBJOuvres(Td(B), Tf(B))
                                        If Range("H" & A + 1) = "v" Then Tc(B) = "Vert"
                                    Else
                                        Tnj(B) = ""
                                    End If
 
 
                                    Ts(B) = DateDebut(Dtd).Offset(, -3)
                                Else
                                    If Not (IsNumeric(Application.Match(CLng(Td(B)), DateDebut, 0))) Then
                                        Tsys(B) = "L"
                                    End If
                                End If
 
                                Tc(B) = "Bleu"
                            End If
                        End If
                    Else
                        '-- Si la différence est égal à un jour
 
                        ReDim Preserve Td(1 To B)
                        ReDim Preserve Tf(1 To B)
                        ReDim Preserve Ts(1 To B)
                        ReDim Preserve Tsys(1 To B)
                        ReDim Preserve Tc(1 To B)
                        ReDim Preserve Tnj(1 To B)
 
                        Td(B) = CLng(DateDebut(A))
                        Tf(B) = CLng(DateFin(A))
                        Tsys(B) = DateDebut(A).Offset(, -2)
                        Ts(B) = DateDebut(A).Offset(, -3)
 
                        Tc(B) = ""
                        Tnj(B) = ""
 
                    End If
 
                    '-- Egalité
                ElseIf DateDebut(A + 1) = DateFin(A) Then
 
                    Td(B) = CLng(DateDebut(A))
                    Tf(B) = CLng(DateFin(A) - 1)
                    Tsys(B) = DateDebut(A).Offset(, -2)
                    Ts(B) = DateDebut(A).Offset(, -3)
 
                    Tc(B) = "Jaune"
 
                    '-- Inférieur DateDebut(A+1) < DateFin(a)
                Else
                    Rem~~~~~~~~~~~~~~~~~~~~~~
                    '-- Bas du tableau traité atteint
                    If A = NbLignes Then
 
                        Td(B) = CLng(DateDebut(A))
                        Tf(B) = CLng(DateFin(A))
                        Tsys(B) = DateDebut(A).Offset(, -2)
                        If Tsys(B) = "R" Then
                            Tnj(B) = NBJOuvres(Td(B), Tf(B))
                            If Range("H" & A + 1) = "v" Then Tc(B) = "Vert"
                        Else
                            Tnj(B) = ""
                            Tc(B) = ""
                        End If
                        Ts(B) = DateDebut(A).Offset(, -3)
 
                        Tnj(B) = DateDebut(A).Offset(, -1)
                        If Tf(B) >= DateSerial(Year(Tf(B)), Mois + 1, 0) Then
                            Exit Do
                        End If
 
 
                        B = B + 1
                        ReDim Preserve Td(1 To B)
                        ReDim Preserve Tf(1 To B)
                        ReDim Preserve Ts(1 To B)
                        ReDim Preserve Tsys(1 To B)
                        ReDim Preserve Tc(1 To B)
                        ReDim Preserve Tnj(1 To B)
 
                        Tc(B) = "Bleu"
                        Td(B) = CLng(DateFin(A) + 1)
 
                        '-- DateFin = dernier jour du mois en cours
                        Tf(B) = CLng(DateSerial(Year(DateFin(A)), Month(DateFin(A)) + 1, 0))
 
                        '-- Recherche du système qui correspond à la date max
                        '-- dans les dates de fin
                        Set Rg = Range(Sh.Name & "!" & Range(DateFin(1, 1).Address & ":" & DateFin(A, 1).Address).Address)
                        M = Application.Max(Rg)
 
                        If DateDebut(A) < M Then
                            Dtd = Application.Match(CLng(M), DateFin, 0)
                            If IsNumeric(Dtd) And DateDebut(Dtd).Offset(, -2) <> "R" Then
                                Tsys(B) = DateDebut(Dtd).Offset(, -2)
                                If Tsys(B) = "R" Then
                                    Tnj(B) = NBJOuvres(Td(B), Tf(B))
                                    If Range("H" & A + 1) = "v" Then Tc(B) = "Vert"
                                Else
                                    Tnj(B) = ""
                                End If
 
                                Ts(B) = DateDebut(Dtd).Offset(, -3)
                            Else
                                If Not (IsNumeric(Application.Match(CLng(Td(B)), DateDebut, 0))) Then
                                    Tsys(B) = "L": Ts(B) = "L"
                                End If
                            End If
                        End If
 
                        ' -- Pas encore bas du tableau traité
                    Else
 
                        Td(B) = CLng(DateDebut(A))
                        Tf(B) = CLng(DateDebut(A + 1) - 1)
                        Tsys(B) = DateDebut(A).Offset(, -2)
                        Tc(B) = "Jaune"
                        If Tsys(B) = "R" Then
                            Tnj(B) = NBJOuvres(Td(B), Tf(B))
                            Rcp1 = Rcp - Tnj(B)
 
                            '-- Rechercher une date non fériée + non WE
                            Call TrouveDate(Tf(B) + 1, Rcp1, A, NbLignes)
 
                            '-- Redifinition des plages
                            Rem ___________________________
                            With Sh
                                MsgBox "Feuille : " & Sh.Name & vbCrLf & _
                                       "Adr : " & .Range("A1:A" & .Range("A18").End(xlUp).Row).Address
                                .Range("A1:A" & .Range("A18").End(xlUp).Row).Select
                                With .Range("A1:A" & .Range("A18").End(xlUp).Row)
                                    'Ligne du début
                                    LD = .Find(What:=Nom, LookIn:=xlValues, lookAt:=xlWhole, searchdirection:=xlNext).Row
                                    'Ligne du fin
                                    LF = .Find(What:=Nom, LookIn:=xlValues, lookAt:=xlWhole, searchdirection:=xlPrevious).Row
                                End With
 
                                '-- Trier la plage sur la colonne Début
                                With .Range("A" & LD & ":H" & LF)
                                    .Sort Key1:=.Item(1, 5), order1:=xlAscending, Header:=xlNo
                                End With
 
                                '-- Plage pour les dates du début
                                Set DateDebut = .Range("E" & LD & ":E" & LF)
 
                                '-- Plage pour les dates de fin
                                Set DateFin = .Range("F" & LD & ":F" & LF)
 
                                '-- Plage pour les systèmes
                                '                            Set Sys = .Range("C" & LD & ":C" & LF)
 
                                '-- Nombre de lignes de la plage
                                NbLignes = DateDebut.Cells.Count
 
                            End With
                            Rem ______________________________
 
                        Else
                            Tnj(B) = ""
                        End If
                        Ts(B) = DateDebut(A).Offset(, -3)
 
                    End If
                End If
            End If
            A = A + 1
        Loop
        With Sh
            .Range("A1:G1").Copy .Range("A19:H19")
            .Range("E20").Offset(S).Resize(UBound(Td)) = Application.Transpose(Td)
            .Range("F20").Offset(S).Resize(UBound(Tf)) = Application.Transpose(Tf)
            .Range("E20:F20").Offset(S).Resize(UBound(Tf)).NumberFormat = "DD/MM/YYYY"
            .Range("C20").Offset(S).Resize(UBound(Tsys)) = Application.Transpose(Tsys)
            .Range("H20").Offset(S).Resize(UBound(Tc)) = Application.Transpose(Tc)
            .Range("A20").Offset(S).Resize(UBound(Tf)) = DateDebut(1).Offset(, -4)
            .Range("B20").Offset(S).Resize(UBound(Ts)) = Application.Transpose(Ts)
            .Range("D20").Offset(S).Resize(UBound(Tnj)) = Application.Transpose(Tnj)
        End With
 
        S = S + B
        A = 0: B = 0
    Next G
 
 
    Set Plg = Sh.Range(Range("A20"), Range("G200").End(xlUp).Row)
 
    With Plg
        On Error Resume Next
        .AutoFilter field:=8, Criteria1:="Jaune"
        ' En cas ou il y a des lignes marquées en Jaune
        If Plg.SpecialCells(xlCellTypeVisible).Rows.Count > 0 Then
            .Offset(1).Resize(Plg.Rows.Count - 1, Plg.Columns.Count - 1).SpecialCells(xlCellTypeVisible).Interior.Color = 65535
        End If
        .AutoFilter field:=8, Criteria1:="Bleu"
        ' En cas ou il y a des lignes marquées en Bleu
        If Plg.SpecialCells(xlCellTypeVisible).Rows.Count > 0 Then
            .Offset(1).Resize(Plg.Rows.Count - 1, Plg.Columns.Count - 1).SpecialCells(xlCellTypeVisible).Interior.Color = 15853019    '16777164
        End If
        .AutoFilter field:=8, Criteria1:="Vert"
        ' En cas ou il y a des lignes marquées en Vert
        If Plg.SpecialCells(xlCellTypeVisible).Rows.Count > 0 Then
            .Offset(1).Resize(Plg.Rows.Count - 1, Plg.Columns.Count - 1).SpecialCells(xlCellTypeVisible).Interior.Color = 12379351
        End If
        On Error GoTo 0
        .AutoFilter
        .Columns(.Columns.Count).Clear
    End With
 
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Fonctions et procédure appelées par la procédure principale :

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
Option Explicit
Public Function PlusJOuvres(D, NbJours)
    Dim Dt, i
    Dim An As Integer
    Dt = CLng(D - 1)
    Do Until i > NbJours - 1
        Dt = Dt + 1
        'ajoute si ouvré
        If (IsError(Application.Match(Dt, [Fériés], 0))) = True And _
           (Weekday(Dt, vbSunday) < 6) = True Then
            i = i + 1
        End If
    Loop
    PlusJOuvres = Dt
 
End Function
 
Public Function NBJOuvres(Dd, Df)
    Dim Dt, i
    Dim An As Integer
 
    Dt = CLng(Df)
    Do
        If (IsError(Application.Match(Dt, [Fériés], 0))) = True And _
           (Weekday(Dt, vbSunday) < 6) = True Then
            i = i + 1
        End If
        Dt = Dt - 1
 
    Loop Until CLng(Dd) > CLng(Dt)
 
    NBJOuvres = i
 
End Function
 
 
Sub TrouveDate(DateC, Rcp, A, DerLg)
    Dim Dch As Date, DateMax As Long, DMax As Long   'Date
    Dim R As Long, Dif As Long, Reste As Boolean
    Dim N As String, Sys As String, Ldf As Long
    Dim Maxx
    DateMax = CLng(DateC)
    MsgBox "Date de commencemenent : " & CDate(DateMax)
 
    'Ligne suivante, on travaille sur la feuille
    Lc = A + 2
    Reste = True
    '--
    Do Until Lc > DerLg + 1
        ' si ce n'est pas un jour ouvré
        If (IsError(Application.Match(DateMax, [Fériés], 0))) = True And _
           (Weekday(DateMax, vbSunday) < 6) = True Then
            If Day(DateMax) >= Day(Range("E" & Lc)) And Day(DateMax) <= Day(Range("F" & Lc)) Then
                'Si c'est une période avec système L ou vide
                If Range("C" & Lc) = "L" Or Range("C" & Lc) = "" Then
                    '-- Durée en jours de la période en cours de traitement
                    Dif = Range("F" & Lc) - DateMax
                    R = R + 1
                    ReDim Dd(1 To R)
                    ReDim Df(1 To R)
 
                    '-- Est-ce qu'elle peut contenir tous les jours de repos
                    If Dif <= Rcp Then
                        Reste = True    ' Ca veut dire qu'il reste encore des jours de récupération
                        Rcp = Rcp - Dif
                        Dd(R) = DateMax
                        Df(R) = PlusJOuvres(Dd(R), Dif)
                        DateMax = Df(R) + 1
                    Else
 
                        If Day(DateMax) >= Application.Max(Range("F1:F" & DerLg), 2) & Day(DateSerial(Year(Date), Month(DateMax) + 1, 0)) Then
                            DMax = Application.Match(Application.Max(Range("F1F" & DerLg)), 0)
                            If (IsNumeric(DMax)) And Range("C" & DMax) = "L" Then
                                Dd(R) = DateMax
                                Df(R) = PlusJOuvres(Dd(A), Rcp)
                                N = Range("A" & Lc)
                                Reste = False    ' Tous les jours Rcp qui restaient seront apurés
                            Else
                                MsgBox "Pas d'apuration"
 
                            End If
                        End If
                    End If
                Else
                    DateMax = CLng(Range("F" & Lc)) + 1
                End If
            Else
                If Lc > DerLg Then
                    '-- Le systeme du max
                    Maxx = Application.Max(Range("F2:F" & Lc))
                    If DateMax < Maxx Then
                        Ldf = Application.Match(Maxx, Range("F2:F" & Lc), 0)
                        If IsNumeric(Ldf) Then
                            Sys = Range("C" & Ldf + 1)
                        Else
                            Sys = ""
                        End If
                        If Sys = "L" Or Sys = "" Then
                            R = R + 1
                            ReDim Dd(1 To R)
                            ReDim Df(1 To R)
 
                            Dd(R) = DateMax
                            Df(R) = CLng(PlusJOuvres(CDate(Dd(R)), Rcp))
                            Reste = False
                        End If
                    End If
 
                End If
                ' Pas trouvé dans la période en cours
                ' On passe à la ligne suivante
                Lc = Lc + 1
            End If
        Else    ' On cherche par la date suivante
            DateMax = DateMax + 1
            If Day(DateMax) = Day(DateSerial(Year(DateMax), Month(DateMax) + 1, 0)) Then
                Exit Do
            Else
                Debug.Print "Nouvelle date : " & CDate(DateMax); ", date suivante "
            End If
        End If
    Loop
    R = 0
    If Not Reste Then
        With Sheets("Données")
            .Range("A" & DerLg + 2 & ":G" & DerLg + 2).Resize(UBound(Dd)).Insert shift:=xlDown
            .Range("E" & DerLg + 2).Resize(UBound(Dd)) = Application.Transpose(Dd)
            .Range("F" & DerLg + 2).Resize(UBound(Df)) = Application.Transpose(Df)
            .Range("A" & DerLg + 2).Resize(UBound(Dd)) = .Range("A" & Lc - 1)
            .Range("B" & DerLg + 2).Resize(UBound(Dd)) = "L"
            .Range("C" & DerLg + 2).Resize(UBound(Dd)) = "R"
            .Range("D" & DerLg + 2).Resize(UBound(Dd)) = NBJOuvres(.Range("E" & DerLg + 2), .Range("F" & DerLg + 2))
            .Range("H" & DerLg + 2).Resize(UBound(Dd)) = "v"
        End With
        If Rcp > 0 Then MsgBox "Il reste " & Rcp & " jour(s) "
    Else
        MsgBox "Il reste quand même : " & Rcp & " jour(s) !"
    End If
End Sub

Merci d'avance.

[nibledispo]

Bonjour APT,

Sur mon ordinateur le code bug sur la ligne suivante:

Code :

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

Set Plg = Sh.Range(Range("A20"), Range("G200").End(xlUp).Row)

"erreur d'exécution 1004 - la méthode "range" de l'objet "Worksheet" a échoué."

Cela est peut-être dû à ma version 2013 mais je ne le pense pas.

Cordialement.

Re....,

Deux essais effectués en modifiant séparément :
- 1ère ligne SSS la datefin = 31/07/2013 comme dans ton fichier d'origine.
- 2ème ligne SSS la date debut = 10/07/2013 (datefin précédente remise à son état de départ.)

Dans les deux cas le résultat n'est pas au rendez-vous.

En fait, il faut je crois distinguer 6 cas de figure sachant que pour un nom donné la datedebut est triée dans un ordre croissant avant le traitement.

la datedebut "n" est inférieure à datefin "n-1"
la datedebut "n" est égale à datefin "n-1"
la datedebut "n" est supérieure à datefin "n-1"
la datefin "n" est inférieure à datefin "n-1"
la datefin "n" est égale à datefin "n-1"
la datefin "n" est supérieure à datefin "n-1"

De plus, le cas épineux du mois de la datedebut <> du mois de la datefin n'est pas traité. Ce qui fait que le bilan sur un mois donné est faussé.
Dans ton exemple c'est le cas de la première ligne xxx.

Peut-être as-tu décidé de revoir les contraintes à la baisse.

Cordialement.

[apt]

Bonjour nibledipo,

Code :

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

1
2
 
Set Plg = Sh.Range(Range("A20"), Range("G200").End(xlUp).Row)

"erreur d'exécution 1004 - la méthode "range" de l'objet "Worksheet" a échoué."

Remplace la ligne en faute par celle-ci :

Code :

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

Set Plg = Sh.Range("A20:H" & Cells(Rows.Count, 8).End(xlUp).Row)

Deux essais effectués en modifiant séparément :
- 1ère ligne SSS la datefin = 31/07/2013 comme dans ton fichier d'origine.
- 2ème ligne SSS la date debut = 10/07/2013 (datefin précédente remise à son état de départ.)

Dans les deux cas le résultat n'est pas au rendez-vous.

Le 31/07/2013 est la troisième ligne avec SSS dans l'exemple.

Tu peux remarquer que les lignes ou on a comme 7 le mois des dates, sont deja traitées et ont des couleurs.

C'est pour ça qu'on a pas touché à nouveau à ces periodes deja traitées.

Et qu'as-tu mis dans la date de debut avant le 31/07/2013, et la date de fin aprés le 10/07/2013 ?

Tu veut dire qu'on a :

SSS - ? - 31/07/2013
SSS - 10/07/2013 - ?

Et le résultat du test, ça a donné quoi ?

En fait, il faut je crois distinguer 6 cas de figure sachant que pour un nom donné la datedebut est triée dans un ordre croissant avant le traitement.

J’essaye toujours, mais j’avancerai bien avec l'aide des autres.

De plus, le cas épineux du mois de la datedebut <> du mois de la datefin n'est pas traité.

Toute date ayant le mois différent du mois en traitement, sera laisser telle qu’elle est.

Donc pour l'exemple ou on a :

XXX - L - CA - 13/07/2013 - 12/08/2013
XXX - L - Prm - 08/08/2013 - 08/08/2013

On aura :

XXX - L - CA - 13/07/2013 - 07/08/2013
XXX - L - Prm - 08/08/2013 - 08/08/2013
XXX - L - CA - 09/08/2013 - 12/08/2013

Peut-être as-tu décidé de revoir les contraintes à la baisse.

J'aimerais généraliser le code pour qu'il traite la maximum des cas de figures qui peuvent se présenter.

Voila !