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.