[RESOLU] - Macro pour faire un sous total avec 2 fonctions

W

white-angel

XLDnaute Nouveau
Bonjour à tous !

Je reviens une nouvelle fois vers vous car vous avez toujours trouvé une solution à mes problèmes :D
Je vous explique mon nouveau problème.
J'ai un tableau de donnée. Je souhaite faire un sous total sur certaines colonnes. Jusque là tout va bien. Mais ... je souhaite aussi avoir 2 fonctions différentes pour un même sous total.
Je m'explique :
En colonne A, j'ai le nom des personnes travaillant dans ma société.
En colonne B, J'ai la date de travail
En colonne C, j'ai le lieu ou il a travaillé.
En colonnes D et E, j'ai le détail de ses heures.
En colonne F, j'ai la durée complète de travail.

Je voudrais avoir un sous total trié par personne (colonne A), avec un nombre de cellule non vide en sous total B, et une somme en sous total F.

Un fichier d'exemple est disponible.

Le tout par macro.
Actuellement, j'ai une macro qui me fait mon sous total avec cette ligne de code :

Code: 
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6, 13, 14, _
    15, 16, 17, 18, 19, 20, 21), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

Ce code me permet bien d'avoir une somme en sous total sur mes différentes personnes... Mais je ne peux pas y rajouter la fonction "nombre" en array 2.
Merci pour vos lumières.

White-Angel
 

Pièces jointes

  • sous total double fonction.xlsx
    13.8 KB · Affichages: 48
Dernière édition:
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : Macro pour faire un sous total avec 2 fonctions

Bonjour white-angel,

Le code de la feuille "Sous-total" du fichier joint :

Code: 
Private Sub Worksheet_Activate()
Dim c As Range
Application.ScreenUpdating = False
Rows.ClearOutline 'supprime le plan
Sheets("Données").[A:F].Copy [A1]
[A:F].Sort [A1], xlAscending, Header:=xlYes
With [A1].CurrentRegion
  .Columns(6).NumberFormat = "[h]:mm"
  .Subtotal 1, xlSum, Array(6), True, SummaryBelowData:=True
End With
With [A1].CurrentRegion
  .AutoFilter 1, "Total*" 'filtre automatique
  For Each c In Intersect([B:B], .SpecialCells(xlCellTypeVisible))
    If c.Row > 1 Then
      c(, 5).Copy c
      c.Replace "(9", "(3", xlPart
      c.NumberFormat = "0"
      c.Font.ColorIndex = 3 'rouge
    End If
    c.EntireRow.Font.Bold = True 'gras
  Next
  .Parent.AutoFilterMode = False
  .Columns.AutoFit 'ajustement largeur
End With
End Sub
La macro s'exécute quand on active la feuille.

A+
 

Pièces jointes

  • sous total double fonction(1).xlsm
    22.4 KB · Affichages: 34
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour faire un sous total avec 2 fonctions

Re,

A la réflexion des gens peuvent très bien avoir un nom commençant par "Total" donc utiliser :

Code: 
Private Sub Worksheet_Activate()
Dim c As Range
Application.ScreenUpdating = False
Rows.ClearOutline 'supprime le plan
Sheets("Données").[A:F].Copy [A1]
[A:F].Sort [A1], xlAscending, Header:=xlYes
With [A1].CurrentRegion
  .Columns(6).NumberFormat = "[h]:mm"
  .Subtotal 1, xlSum, Array(6), True, SummaryBelowData:=True
End With
With [A1].CurrentRegion
  .AutoFilter 1, "Total*" 'filtre automatique
  For Each c In Intersect([B:B], .SpecialCells(xlCellTypeVisible))
    If c(, 5).Formula Like "*(9*" Then
      c(, 5).Copy c
      c.Replace "(9", "(3", xlPart
      c.NumberFormat = "0"
      c.Font.ColorIndex = 3 'rouge
      c.EntireRow.Font.Bold = True 'gras
    End If
  Next
  .Rows(1).Font.Bold = True '1ère ligne gras
  .Parent.AutoFilterMode = False
  .Columns.AutoFit 'ajustement largeur
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • sous total double fonction(2).xlsm
    22.6 KB · Affichages: 33
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour faire un sous total avec 2 fonctions

Re,

Bah il y a plus simple, utilisez cette macro :

Code: 
Private Sub Worksheet_Activate()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
Rows.ClearOutline 'supprime le plan
Sheets("Données").ShowAllData 'si la feuille est filtrée
Sheets("Données").[A:F].Copy [A1]
[A:F].Sort [A1], xlAscending, Header:=xlYes 'tri sur les noms
With [A1].CurrentRegion
  .Columns(2).HorizontalAlignment = xlCenter
  .Columns(6).NumberFormat = "[h]:mm"
  .Subtotal 1, xlSum, Array(2, 6), True, SummaryBelowData:=True
End With
For Each c In [A1].CurrentRegion.Columns(2).SpecialCells(xlCellTypeFormulas)
  c.Replace "(9", "(3", xlPart
  c.NumberFormat = "0"
  c.Font.ColorIndex = 3 'rouge
  c.EntireRow.Font.Bold = True 'gras
Next
Rows(1).Font.Bold = True '1ère ligne en gras
Columns.AutoFit 'ajustement largeur
End Sub
Edit : si la feuille "Données" est filtrée il faut préalablement afficher toutes les données.

Fichier (3).

A+
 

Pièces jointes

  • sous total double fonction(3).xlsm
    22.5 KB · Affichages: 51
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour faire un sous total avec 2 fonctions

Bonjour white-angel, le forum,

Il vaut mieux utiliser Cells.Delete au début et copier la hauteur de la 1ère ligne :

Code: 
Private Sub Worksheet_Activate()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
Cells.Delete 'RAZ
With Sheets("Données")
  .ShowAllData 'si la feuille est filtrée
  .[A:F].Copy [A1] 'colonnes à adapter
  Rows(1).RowHeight = .Rows(1).RowHeight 'hauteur de la 1ère ligne
End With
Me.UsedRange.Sort [A1], xlAscending, Header:=xlYes 'tri sur les noms
With [A1].CurrentRegion
  .Columns(2).HorizontalAlignment = xlCenter
  .Columns(6).NumberFormat = "[h]:mm"
  .Subtotal 1, xlSum, Array(2, 6), True, SummaryBelowData:=True
End With
For Each c In [A1].CurrentRegion.Columns(2).SpecialCells(xlCellTypeFormulas)
  c.Replace "(9", "(3", xlPart
  c.NumberFormat = "0"
  c.Font.ColorIndex = 3 'rouge
  c.EntireRow.Font.Bold = True 'gras
Next
Rows(1).Font.Bold = True '1ère ligne en gras
Columns.AutoFit 'ajustement largeur
End Sub
Fichier (4).

Bonne journée.
 

Pièces jointes

  • sous total double fonction(4).xlsm
    22.9 KB · Affichages: 32
  • sous total double fonction(4).xlsm
    22.9 KB · Affichages: 39
  • sous total double fonction(4).xlsm
    22.9 KB · Affichages: 33
Vote positif 0 Vote négatif
W

white-angel

XLDnaute Nouveau
Re : Macro pour faire un sous total avec 2 fonctions

Bonjour job75, forum.

Merci pour ces réponses.
J'essaye d'adapter sur mon tableau déjà existant.
Malheureusement, (et c'est de ma faute) ça ne marche pas.
En effet, le ".CurrentRegion" prend le tableau complet.
Or dans mon fichier réel, mes entêtes (Nom, Date lieu heure ... etc) sont en A3.
Et il n'y a pas de saut de ligne entre A2 et A3.
Donc le CurrentRegion me prend mon tableau depuis [A1] (même si je met [A3] (normal). Et forcément, il me sort une erreur.
Je ne peux pas simplement sauter une ligne entre A2 et A3 car il y a différentes macros et elles sont déjà toutes réglées avec A3 en référence de début. Changer ce paramètre changerait tout !!

Actuellement, la macro vient prendre les données de mes differents onglets de traitement, les colle toutes dans mon recap, les tries, fais les sous totaux (je sélectionne de A3 à A et dernière ligne non vide de mon tableau pour faire mon sous total) et fait la mise en page.
N'y a t'il pas possibilité de lui demander de travailler sur cette sélection ? Mes tentatives ont échoué !!

Je reprends votre tableau et l'adapte.
Toute la mise en page est futile pour moi car une macro s'en charge déjà. Donc pas besoin de mettre en gras en rouge tout ça tout ça :). Il faudrait vraiment juste que les sous totaux de la date se transforment en nombre de cellules non vide.
Merci encore pour votre aide !!
 

Pièces jointes

  • sous total double fonction(4).xlsm
    24.5 KB · Affichages: 37
  • sous total double fonction(4).xlsm
    24.5 KB · Affichages: 40
  • sous total double fonction(4).xlsm
    24.5 KB · Affichages: 32
Vote positif 0 Vote négatif
W

white-angel

XLDnaute Nouveau
Re : Macro pour faire un sous total avec 2 fonctions

Avec de la persévérance on arrive à tout !!!
J'ai pu adapter et ça fonctionne.

Code: 
Option Explicit

Private Sub Worksheet_Activate()
Dim derli As String
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
Cells.Delete 'RAZ
With Sheets("Données")
  .ShowAllData 'si la feuille est filtrée
  .[A:F].Copy [A1] 'colonnes à adapter
  Rows(1).RowHeight = .Rows(1).RowHeight 'hauteur de la 1ère ligne
End With
Me.UsedRange.Sort [A2], xlAscending, Header:=xlYes 'tri sur les noms
    derli = Cells(Application.Rows.Count, 1).End(xlUp).Row
    Range("A3:F" & derli & "").Select
With Selection
  .Columns(2).HorizontalAlignment = xlCenter
  .Columns(6).NumberFormat = "[h]:mm"
  .Subtotal 1, xlSum, Array(2, 6), True, SummaryBelowData:=True
End With
    derli = Cells(Application.Rows.Count, 1).End(xlUp).Row
    Range("A3:F" & derli & "").Select
For Each c In [A1].CurrentRegion.Columns(2).SpecialCells(xlCellTypeFormulas)
  c.Replace "(9", "(3", xlPart
  c.NumberFormat = "0"
  c.Font.ColorIndex = 3 'rouge
  c.EntireRow.Font.Bold = True 'gras
Next
Rows(1).Font.Bold = True '1ère ligne en gras
Columns.AutoFit 'ajustement largeur
End Sub

La macro vient prendre la dernière ligne du tableau en partant de A3. Elle fait ses sous totaux.
Puis, elle vient reprendre la dernière ligne du tableau, et utilise la fonction de job75 pour modifier les sous totaux de la colonne B.
Le code n'est peut être pas le plus propre qu'il soit, mais ça fonctionne. (je parles du code dans mon fichier réel)

Merci à job75 qui a pu m'aider !!! Merci merci merci :)

ci joint, le tableau d'exemple.
 

Pièces jointes

  • sous total double fonction(5).xlsm
    25.1 KB · Affichages: 39
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Macro pour faire un sous total avec 2 fonctions

Re,

Une chose qu'il faut impérativement vous mettre dans la tête : en VBA il est presque toujours inutile, voire nuisible, de sélectionner quoi que ce soit.

Les Select ou Activate sont donc à proscrire.

Ma macro s'adapte facilement à votre dernier fichier :

Code: 
Private Sub Worksheet_Activate()
Dim c As Range
Application.ScreenUpdating = False
On Error Resume Next
Cells.Delete 'RAZ
With Sheets("Données")
  .ShowAllData 'si la feuille est filtrée
  .[A:F].Copy [A1] 'colonnes à adapter
  .Rows("1:3").Copy [A1] 'pour copier les hauteurs des lignes
End With
[A3:F3].Resize(Rows.Count - 2).Sort [A3], xlAscending, Header:=xlYes 'tri sur les noms
With Intersect(Me.UsedRange, Rows("3:" & Rows.Count))
  .Columns(2).HorizontalAlignment = xlCenter
  .Columns(6).NumberFormat = "[h]:mm"
  .Subtotal 1, xlSum, Array(2, 6), True, SummaryBelowData:=True
End With
For Each c In [B3].Resize(Rows.Count - 2).SpecialCells(xlCellTypeFormulas)
  c.Replace "(9", "(3", xlPart
  c.NumberFormat = "0"
  c.Font.ColorIndex = 3 'rouge
  c.EntireRow.Font.Bold = True 'gras
Next
Rows("1:3").Font.Bold = True 'lignes en gras
Columns.AutoFit 'ajustement largeur
End Sub
Fichier (6).

A+
 

Pièces jointes

  • sous total double fonction(6).xlsm
    23.3 KB · Affichages: 38
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

C
  • Résolu(e)
XL 2013 Sous-total erroné
Réponses
6
Affichages
339
chris
chris
I
  • Résolu(e)
Microsoft 365 insérer des sous total entre chaque groupe de compte
2
Réponses
19
Affichages
1 K
chris
chris
jeanmi
  • Question
XL 2010 sous total avec condition
Réponses
12
Affichages
583
jeanmi
jeanmi
S
  • Résolu(e)
Microsoft 365 Faire des calculs automatiques sur un calendrier perpétuel avec enregistrements de données
Réponses
2
Affichages
186
sebastien176
S
V
  • Question
XL 2016 Champs calculés dans un TCD
Réponses
4
Affichages
513
chris
chris
R
  • Question
XL 2019 somme total par fnrs
Réponses
4
Affichages
412
Romain.Gib
R
P
  • Question
Microsoft 365 Besoin d'aide pour plusieurs petite chose technique sur un fichier excel
8 9 10
Réponses
136
Affichages
6 K
TooFatBoy
TooFatBoy
oguruma
POWERQUERY :: Faire la somme d'un tableau horizontalement et verticalement (somme des lignes, somme des colonnes)
Réponses
0
Affichages
188
oguruma
oguruma
C
  • Question
XL 2013 problème avec formule Sous total(fonction_num;REf1:Ref2)
Réponses
4
Affichages
502
cd92600
C
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
229
guiyom
G

Membres actuellement en ligne

16 membres et 91 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 216
Messages
2 086 342
Membres
103 192
dernier inscrit
Corpdacier