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

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
W

white-angel

XLDnaute Nouveau
Bonjour à tous !

Je reviens une nouvelle fois vers vous car vous avez toujours trouvé une solution à mes problèmes 😀
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

Dernière édition:
Trier par date Trier par votes
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

Vote positif 0 Vote négatif
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

Dernière édition:
Vote positif 0 Vote négatif
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

Dernière édition:
Vote positif 0 Vote négatif
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

Vote positif 0 Vote négatif
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

Vote positif 0 Vote négatif
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

Vote positif 0 Vote négatif
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

Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

richardlion
  • Question Question
XL 2016 graph avec 2 tcd
Réponses
5
Affichages
70
Hecatonchire
H
GADENSEB
  • Résolu(e)
Microsoft 365 Powerquery - Total par Compte / lignes en insérant des colonnes
Réponses
5
Affichages
173
chris
chris
Roseline
  • Question Question
Microsoft 365 Calculer le nombre de valeur
Réponses
5
Affichages
91
Jean-Eric
Jean-Eric
P
  • Résolu(e)
Microsoft 365 Optimiser le Suivi des Paiements Clients : Vos Astuces pour un Tableau Ergonomique sous le Total N14 serais quoi ?
3 4 5
Réponses
63
Affichages
1 K
wDog66
wDog66
N
  • Résolu(e)
Microsoft 365 Macro copier/coller entre deux tableaux structurés
3 4 5
Réponses
66
Affichages
2 K
job75
job75
N
  • Question Question
XL 2019 insertion de lignes et sous-total
Réponses
2
Affichages
304
nasser
N
G
  • Question Question
Microsoft 365 Macro VBA - mise en forme export excel
Réponses
6
Affichages
492
gpera
G
G
  • Question Question
Microsoft 365 Répartition d'heures sous conditions
Réponses
5
Affichages
330
Guesh
G
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
331
Gestionnaire_rh
G
L
  • Question Question
XL 2019 Créer des dossiers et sous dossiers avec VBA
2
Réponses
19
Affichages
397
patricktoulon
patricktoulon
S
  • Résolu(e)
Microsoft 365 [RESOLU] Excel : Calcul de prix en fonction d'un type
Réponses
4
Affichages
270
JHA
J
P
  • Question Question
XL 2016 Réaliser un classement dans un TCD sous conditions
Réponses
7
Affichages
710
Pilliars
P
C
  • Résolu(e)
XL 2013 Sous-total erroné
Réponses
6
Affichages
643
chris
chris
C
  • Résolu(e)
XL 2021 Sauvegarder répertoire/sous répertoire un peu volumineux 2 Go
Réponses
7
Affichages
240
Claudinedu13
C
looky62
  • Question Question
Microsoft 365 PB Concaténation de ref en une phrase
Réponses
3
Affichages
410
looky62
looky62
I
  • Résolu(e)
Microsoft 365 insérer des sous total entre chaque groupe de compte
2
Réponses
19
Affichages
2 K
chris
chris
F
  • Résolu(e)
XL 2010 Macro : Remplissage de texte sous conditions
Réponses
11
Affichages
278
FLG
F
G
  • Résolu(e)
Microsoft 365 Recherche avec 2 critères pour non vide et somme
Réponses
5
Affichages
81
gpion
G
N
  • Question Question
XL 2016 Afficher un "X" dans un tableau semaine en fonction d'un récurrence Horaire
Réponses
2
Affichages
244
nicobush
N
P
  • Question Question
XL 2016 Macro VBA remplissage tableau de synthèse % déchet ligne de production
Réponses
4
Affichages
75
vgendron
vgendron
Retour