Récupérer Dates de début et fin d'une action dans un calend

Question

*rier

Bonjour cher membres du forum !

J'ai ici un listing d'actions par personnes avec les dates où ils y sont affectés.

J'ai déjà récupéré le nombre de jours par action et par personnes, j'aimerais maintenant avoir en plus le premier et dernier jour de chaque action.

J'ai pensé à une boucle où il faudrait voir les blocs contigües de cellules vides et non vides, mais je n'arrive pas à avoir toutes les dates, en particulier quand une même personne a fait plusieurs actions, comme pour ma personne "B. A." Voici ce que j'avais tenté (sachant que diverses variables sont définie en amont). Ces dates seront à copier au sein d'un autre tableau comprenant les 5 colonnes action (alpha, etc...) et le nom des personnes en ligne.

With ThisWorkbook.Sheets("TEMP")
    For l = 2 To derligne_TCD
        If .Cells(l, 1).Value Like "Total*" Then
            If .Cells(l, 3).Value <> "" Then
                If .Cells(l - 1, 3).Value <> "" Then
                    .Cells(l - 1, 2).Copy .Cells(l - 1, 10)
                Else
                    If .Cells(l, 3) = "" Then
                        ActiveSheet.Cells(l - 1, 3).Copy .Cells(l - 1, 10)
                        Exit For
                    End If
                End If
            End If

            If .Cells(l, 4).Value <> "" Then
                If .Cells(l - 1, 4).Value <> "" Then
                    .Cells(l - 1, 2).Copy .Cells(l - 1, 10)
                Else
                    If .Cells(l, 4) = "" Then
                        ActiveSheet.Cells(l - 1, 4).Copy .Cells(l - 1, 11)
                        Exit For
                    End If
                End If
            End If

            If .Cells(l, 5).Value <> "" Then
                If .Cells(l - 1, 5).Value <> "" Then
                    .Cells(l - 1, 2).Copy .Cells(l - 1, 10)
                Else
                    If .Cells(l, 5) = "" Then
                        ActiveSheet.Cells(l - 1, 5).Copy .Cells(l - 1, 12)
                        Exit For
                    End If
                End If
            End If

            If .Cells(l, 6).Value <> "" Then
                If .Cells(l - 1, 6).Value <> "" Then
                    .Cells(l - 1, 2).Copy .Cells(l - 1, 10)
                Else
                    If .Cells(l, 6) = "" Then
                        ActiveSheet.Cells(l - 1, 6).Copy .Cells(l - 1, 13)
                        Exit For
                    End If
                End If
            End If

            If .Cells(l, 7).Value <> "" Then
                If .Cells(l - 1, 7).Value <> "" Then
                    .Cells(l - 1, 2).Copy .Cells(l - 1, 10)
                Else
                    If .Cells(l, 7) = "" Then
                        ActiveSheet.Cells(l - 1, 7).Copy .Cells(l - 1, 14)
                        Exit For
                    End If
                End If
            End If

        End If
    Next l
End With

Ci-joint un fichier exemple.

Merci

20test.xlsx (9.34 Ko)

MFerrand · Accepted Answer

Une proposition à essayer : Sub RécapActions() Dim TAc(), act, n%, i%, j%, k%, f%, np$ With ActiveSheet n = .Cells(.Rows.Count, 2).End(xlUp).Row i = 3 Do act = act &amp; ";" &amp; .Cells(2, i): i = i + 1 Loop Until .Cells(2, i) Like "Total*" act = Split(act, ";"): f = UBound(act) + 3 ReDim TAc(f, 0) For i = 3 To n If .Cells(i, 2) &lt;&gt; "" Then For j = 1 To UBound(act) If .Cells(i, j + 2) = 1 Then Exit For Next j If j &gt; UBound(act) Then j = 0 If .Cells(i, 1) &lt;&gt; "" Then k = k + 1: ReDim Preserve TAc(f, k) np = .Cells(i, 1): TAc(0, k) = np TAc(f - 1, k) = .Cells(i, 2).Value2: TAc(f, k) = TAc(f - 1, k) TAc(j + 1, k) = 1 Else If .Cells(i, 2) = .Cells(i - 1, 2) + 1 And TAc(j + 1, k) &gt; 0 Then TAc(f, k) = .Cells(i, 2).Value2 TAc(j + 1, k) = TAc(j + 1, k) + 1 Else k = k + 1: ReDim Preserve TAc(f, k): TAc(0, k) = np TAc(f - 1, k) = .Cells(i, 2).Value2: TAc(f, k) = TAc(f - 1, k) TAc(j + 1, k) = 1 End If End If End If Next i End With For i = 1 To k - 1 For j = i + 1 To k If TAc(0, j) &lt; TAc(0, i) Then For n = 0 To f TAc(n, 0) = TAc(n, j): TAc(n, j) = TAc(n, i): TAc(n, i) = TAc(n, 0) Next n End If Next j Next i k = k + 1: ReDim Preserve TAc(f, k): n = 0 TAc(0, 0) = "Nom Prénom": TAc(f - 1, 0) = "Date début": TAc(f, 0) = "Date fin" For i = 1 To UBound(act) TAc(i + 1, 0) = act(i) For j = 1 To k - 1 n = n + TAc(i + 1, j) Next j TAc(i + 1, k) = n: n = 0 Next i TAc(0, k) = "Total" With Worksheets.Add(after:=ActiveSheet) With .Range("A1").Resize(k + 1, f + 1) .Value = WorksheetFunction.Transpose(TAc) .HorizontalAlignment = xlCenter With .Borders .LineStyle = xlContinuous: .Weight = xlThin End With .Columns(1).ColumnWidth = 20 .Columns(f).NumberFormat = "dd/mm/yyyy" .Columns(f + 1).NumberFormat = "dd/mm/yyy" .Rows(k + 1).Font.Bold = True .Rows(1).Font.Italic = True End With .Activate End With End Sub...

MFerrand · Answer

Pas très clair... ! Et en mettant date début et date fin de chaque action, on aura directement les dates (!), le nombre de jours et le nombre d'actions, et en moins de lignes !! Cordialement...

bouben · Answer

Ci-joint une proposition à tester. A priori, les données proviennent d'un TCD. Si le fournisseur des données à la main sur le TCD, il pourrait directement donner ce résultat dans le TCD, ou fournir les données brutes pour ensuite construire le TCD qui va bien ! (même remarque que MFerrand, hello !) Bonne journée Bouben...

MFerrand · Answer

Il m'était venu à l'idée de faire une procédure pour reconstituer un tableau "origine"... mais pas le temps de tout faire, je suis sur autre chose... Cordialement et bonne journée à tous...