XL 2016 [Résolu] Sommation de nombre de jours sous conditions

[kingfadhel]

Bonjour, les XLdnautes,
Je voudrais faire la somme du nombre de jours sous conditions
1- Le même matricule, un ou plusieurs (CODE, DATE DEBUT, DATE FIN)
2- Suppression des lignes inutiles.

Plus de détails dans la pièce jointe.

 

[job75]

Re,

J'ai ajouté les Application.Calculation pour éviter le recalcul des formules volatiles (DECALER).

J'ai recopié le tableau sur 3200 lignes (avec des matricules différents).

La macro s'exécute chez moi sur Win 10 Excel 2013 en 1,8 seconde.

A+

 

[job75]

Re,

Avec un tableau VBA c'est plus rapide :

Private Sub Worksheet_Activate()
Dim t, ub&, i&, j&
Application.ScreenUpdating = False
With Feuil1.[A1].CurrentRegion 'à adapter
  If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
  .Sort .Columns(2), xlAscending, .Columns(5), , xlAscending, Header:=xlYes 'tri
  .EntireColumn.Copy [A1]
End With
Application.Calculation = xlCalculationManual 'évite le recalcul des formules volatiles
With [A1].CurrentRegion
  .Value = .Value 'supprime les formules
  .Columns(7).Resize(, 2).EntireColumn.Delete
  t = .Columns(6).Resize(, 2): ub = UBound(t)
  For i = 2 To ub
    If t(i, 2) = "" Then
      For j = i + 1 To ub
        If t(j, 2) <> "" Then Exit For
      Next j
      t(i, 1) = t(j, 1): t(i, 2) = t(j, 2): t(j, 2) = ""
      i = j
    End If
  Next i
  .Columns(6).Resize(, 2) = t 'restitution
  On Error Resume Next 'si aucune SpecialCell
  .Columns(7).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.Calculation = xlCalculationAutomatic
With UsedRange: End With 'actualise les barres de défilement
End Sub

Fichier (2).

Sur 3200 enregistrements => 0,96 seconde.

Edit : j'ai essayé de mettre le résultat en Feuil1 mais alors la MFC pose problème.

A+

 

[kingfadhel]

Bonjour,
C'est excellent, mais la formule en H2 (=G2+N(DECALER(H2;-1)*(C2=55)) et I2 (=SI(DECALER(C2;1=55;"";H2)) , en les recopiant dans mon fichier ne donne rien.

 

[kingfadhel]

Re,
@job75
Je voudrais que le tri ce sur 4 colonnes successivement (Matricule, Debut, Fin et Code).
J'ai tenté de modifier ton code mais ça n'a pas bien marché.
Merci

 

[job75]

Re,

Les formules en H2 et I2 sont élémentaires , il faut bien sûr avoir inséré d'abord la colonne A.

Pour trier sur 4 colonnes il faut une autre syntaxe, utilisez l'enregistreur de macro.

Mais je n'en vois pas du tout l'intérêt : une même personne ne va pas avoir un autre accident pendant sa période d'arrêt ! Donc le tri sur 2 colonnes doit suffire.

A+

 

[job75]

Bonjour kingfadhel, le forum,

Edit : j'ai essayé de mettre le résultat en Feuil1 mais alors la MFC pose problème.

Oui mais j'y suis quand même arrivé.

1) En modifiant la formule de la MFC :

=MOD(SI(COLONNE()<12;$A2;$L2);2)

2) En utilisant un document auxiliaire :

Sub Regroupement()
Dim F As Worksheet, t, ub&, i&, j&
Set F = ActiveSheet
Application.ScreenUpdating = False
With F.[A1].CurrentRegion 'à adapter
  If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
  .Sort .Columns(2), xlAscending, .Columns(5), , xlAscending, Header:=xlYes 'tri
  .EntireColumn.Copy Workbooks.Add.Sheets(1).[L1] 'document auxiliaire, à adapter
End With
Application.Calculation = xlCalculationManual 'évite le recalcul des formules volatiles
With ActiveWorkbook.Sheets(1).[L1].CurrentRegion
  .Value = .Value 'supprime les formules
  .Columns(7).Resize(, 2).EntireColumn.Delete
  t = .Columns(6).Resize(, 2): ub = UBound(t)
  For i = 2 To ub
    If t(i, 2) = "" Then
      For j = i + 1 To ub
        If t(j, 2) <> "" Then Exit For
      Next j
      t(i, 1) = t(j, 1): t(i, 2) = t(j, 2): t(j, 2) = ""
      i = j
    End If
  Next i
  .Columns(6).Resize(, 2) = t 'restitution
  On Error Resume Next 'si aucune SpecialCell
  .Columns(7).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  .EntireColumn.Copy F.[L1]
End With
ActiveWorkbook.Close False 'fermeture du document auxiliaire
Application.Calculation = xlCalculationAutomatic
End Sub

Fichier (3).

Sur 3200 enregistrements c'est un peu plus long => 1,6 seconde.

Bonne journée.

 

[kingfadhel]

Bonjour kingfadhel, le forum,

Oui mais j'y suis quand même arrivé.

1) En modifiant la formule de la MFC :

=MOD(SI(COLONNE()<12;$A2;$L2);2)

2) En utilisant un document auxiliaire :

Sub Regroupement()
Dim F As Worksheet, t, ub&, i&, j&
Set F = ActiveSheet
Application.ScreenUpdating = False
With F.[A1].CurrentRegion 'à adapter
  If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
  .Sort .Columns(2), xlAscending, .Columns(5), , xlAscending, Header:=xlYes 'tri
  .EntireColumn.Copy Workbooks.Add.Sheets(1).[L1] 'document auxiliaire, à adapter
End With
Application.Calculation = xlCalculationManual 'évite le recalcul des formules volatiles
With ActiveWorkbook.Sheets(1).[L1].CurrentRegion
  .Value = .Value 'supprime les formules
  .Columns(7).Resize(, 2).EntireColumn.Delete
  t = .Columns(6).Resize(, 2): ub = UBound(t)
  For i = 2 To ub
    If t(i, 2) = "" Then
      For j = i + 1 To ub
        If t(j, 2) <> "" Then Exit For
      Next j
      t(i, 1) = t(j, 1): t(i, 2) = t(j, 2): t(j, 2) = ""
      i = j
    End If
  Next i
  .Columns(6).Resize(, 2) = t 'restitution
  On Error Resume Next 'si aucune SpecialCell
  .Columns(7).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  .EntireColumn.Copy F.[L1]
End With
ActiveWorkbook.Close False 'fermeture du document auxiliaire
Application.Calculation = xlCalculationAutomatic
End Sub

Fichier (3).

Sur 3200 enregistrements c'est un peu plus long => 1,6 seconde.

Bonne journée.

Bonjour, le forum
@job75 , Merci pour le temps consacré.

 

[job75]

Bonjour kingfadhel, le forum,

Encore 2 améliorations dans ce fichier (4).

1) En nommant N° la 1ère cellule du tableau et en définissant le nom decal, formule de la MFC :

=MOD(DECALER(N°;LIGNE()-LIGNE(N°);decal*(COLONNE()>=COLONNE(N°)+decal););2)

La macro Regroupement est bien sûr adaptée en conséquence.

2) Cette macro supprime la ligne du tableau si la formule en dernière colonne est effacée :

Private Sub Worksheet_Change(ByVal Target As Range)
If ListObjects.Count = 0 Then Exit Sub
On Error Resume Next
With ListObjects(1).DataBodyRange
  Intersect(.Cells, .Columns(.Columns.Count).SpecialCells(xlCellTypeBlanks).EntireRow).Delete xlUp
End With
End Sub

Au cas où vous ne l'auriez pas vu il y a aussi une macro Workbook_Open, assez utile.

A+