Microsoft 365 VBA - EXCEL Compiler plusieurs dates en périodes suivant un code absence

[Pb68]

Bonjour à tous,

J'ai une nouvelle demande un peu similaire à ma précédente faite début 2023. Je remercie au passage @sylvanu @gbinforme pour leur aide.
J'ai essayé de repartir sur le fichier de ma première demande en le modifiant mais je n'arrive pas au résultat attendu.

J'aimerais que pour chaque matricule, on obtient une date de début et une date de fin par code absence (colonne H) en faisant le cumul de la colonne I.
La macro fonction bien sauf que je n'ai pas plusieurs lignes par code absence lorsqu'il y a une interruption de dates.

Exemple :
Mat 00008 : je souhaite avoir 2 lignes

Mat	Date début	Date fin	Abs Code	Abs Qte
00008	20/07/2023​	20/07/2023​	300​	7​
00008	31/07/2023​	06/08/2023​	300​	35​

Mais j'ai un cumul des deux lignes :

Mat	Date début	Date fin	Abs Code	Abs Qte
00008	20/07/2023​	06/08/2023​	300​	42​

J'ai également essayé d'enlever les colonnes en rouge mais malgré mes tentatives de modification de la macro, elle ne s'exécute plus après. J'ai donc laissé les colonnes en rouge mais je n'en ai pas besoin.

Merci d'avance pour votre aide !

 

[JHA]

Bonjour à tous,

Un début par formule et power query pour le regroupement.

JHA

 

[Pb68]

Bonjour JHA,

Merci pour votre réponse. Je n'ai jamais utilisé power query. J'ai ajouté la fonctionnalité mais je ne sais pas quoi faire avec le fichier. Pouvez-vous m'indiquer la marche à suivre svp ?

 

[Oneida]

Bonjour,
Votre demande est celle-ci?
Exemple :
Mat 00008 : je souhaite avoir 2 lignes

Mat	Date début	Date fin	Abs Code	Abs Qte
00008	20/07/2023	20/07/2023	300	7
00008	31/07/2023	06/08/2023	300	35

 

[Pb68]

Bonjour,
Votre demande est celle-ci?
Exemple :
Mat 00008 : je souhaite avoir 2 lignes

Mat	Date début	Date fin	Abs Code	Abs Qte
00008	20/07/2023	20/07/2023	300	7
00008	31/07/2023	06/08/2023	300	35

Bonjour,

Oui c'est bien ça. J'aimerais cette affichage dans l'onglet synthèse.

 

[mapomme]

Bonsoir à tous ,

Via une macro. Cliquer sur le bouton Hop!

nota : le tableau "extraction" n'a pas besoin d'être trié - la macro s'en charge.

Le code de la macro :

Sub GrouperPeriode()
Dim xrg As Range, t0, t, der&, i&, i0
Dim som, ref, j&, n&, datfin As Date, deb
 
   Application.ScreenUpdating = False: deb = Timer
   With Sheets("Extraction")
      If .FilterMode Then .ShowAllData
      Set xrg = Intersect(.Range("a1").CurrentRegion, .Columns("a:i"))
      t0 = xrg.Value
      xrg.Sort key1:=.Range("a1"), order1:=xlAscending, key2:=.Range("g1"), order2:=xlAscending, _
      key3:=.Range("h1"), order3:=xlAscending, MatchCase:=False, Header:=xlYes
      t = xrg.Resize(xrg.Rows.Count + 1, xrg.Columns.Count).Value
      xrg.Value = t0: Erase t0
   End With

   t(1, 1) = "Matricule": t(1, 2) = "Code abs": t(1, 3) = "Date debut": t(1, 4) = "Date fin": t(1, 5) = "Qté abs"
   For i = 2 To UBound(t): t(i, 2) = t(i, 8): t(i, 3) = t(i, 7): t(i, 4) = t(i, 7): t(i, 5) = t(i, 9): Next
   ReDim Preserve t(1 To UBound(t), 1 To 5)
   n = 1: i0 = 2
   For i = 3 To UBound(t)
      If t(i, 1) <> t(i0, 1) Or t(i, 2) <> t(i0, 2) Or t(i, 3) <> t(i - 1, 3) + 1 Then
         n = n + 1
         For j = 1 To 5: t(n, j) = t(i0, j): Next
         i0 = i
      Else
         t(i0, 4) = t(i, 4): t(i0, 5) = t(i0, 5) + t(i, 5)
      End If
   Next i
 
  With Worksheets("synthèse")
      .Range("a1").CurrentRegion.Clear
      .Range("a1").Resize(n, 5) = t
      .Range("e1").Resize(n).NumberFormat = "0.00"
      Application.Goto .Range("a1"), True
   End With
   MsgBox Format(Timer - deb, "0.00\ sec.")
End Sub

 

[Pb68]

Bonsoir à tous ,

Via une macro. Cliquer sur le bouton Hop!

nota : le tableau "extraction" n'a pas besoin d'être trié - la macro s'en charge.

Le code de la macro :

Sub GrouperPeriode()
Dim xrg As Range, t0, t, der&, i&, i0
Dim som, ref, j&, n&, datfin As Date, deb
 
   Application.ScreenUpdating = False: deb = Timer
   With Sheets("Extraction")
      If .FilterMode Then .ShowAllData
      Set xrg = Intersect(.Range("a1").CurrentRegion, .Columns("a:i"))
      t0 = xrg.Value
      xrg.Sort key1:=.Range("a1"), order1:=xlAscending, key2:=.Range("g1"), order2:=xlAscending, _
      key3:=.Range("h1"), order3:=xlAscending, MatchCase:=False, Header:=xlYes
      t = xrg.Resize(xrg.Rows.Count + 1, xrg.Columns.Count).Value
      xrg.Value = t0: Erase t0
   End With

   t(1, 1) = "Matricule": t(1, 2) = "Code abs": t(1, 3) = "Date debut": t(1, 4) = "Date fin": t(1, 5) = "Qté abs"
   For i = 2 To UBound(t): t(i, 2) = t(i, 8): t(i, 3) = t(i, 7): t(i, 4) = t(i, 7): t(i, 5) = t(i, 9): Next
   ReDim Preserve t(1 To UBound(t), 1 To 5)
   n = 1: i0 = 2
   For i = 3 To UBound(t)
      If t(i, 1) <> t(i0, 1) Or t(i, 2) <> t(i0, 2) Or t(i, 3) <> t(i - 1, 3) + 1 Then
         n = n + 1
         For j = 1 To 5: t(n, j) = t(i0, j): Next
         i0 = i
      Else
         t(i0, 4) = t(i, 4): t(i0, 5) = t(i0, 5) + t(i, 5)
      End If
   Next i
 
  With Worksheets("synthèse")
      .Range("a1").CurrentRegion.Clear
      .Range("a1").Resize(n, 5) = t
      .Range("e1").Resize(n).NumberFormat = "0.00"
      Application.Goto .Range("a1"), True
   End With
   MsgBox Format(Timer - deb, "0.00\ sec.")
End Sub

Bonjour Mapomme,

Un grand merci à vous !
C'est exactement ce qu'il me fallait.

Je vous souhaite une excellente journée et de belles fêtes de fin d'année.

Merci également aux autres intervenants.