Sous-total en VBA

K

kabamel

XLDnaute Occasionnel
Salut à tous, je veux faire le sous-total en VBA d'un fichier et même temps fusionner les colonnes dont les valeurs sont identiques. La fusion se fait à deux niveaux, en colonne B pour les jours, on les fusionnes et en colonne A pour les mois et on fusionne, j'espère être compris, je vous joint aussi fichier dans lequel il y a mon macro et un exemple de feuille. Merci pour votre aide.
 

Pièces jointes

  • ExempleSousTotal.xls
    177.5 KB · Affichages: 44
Trier par date Trier par votes
gosselien

gosselien

XLDnaute Barbatruc
Bonjour,

fusionner n'est peut être pas le bon terme...regrouper alors ?
une tentative ici avec ce que j'ai compris et sans VBA, innutile il me semble sauf si les affaires se compliquent ou les données sont trèèèèèèès nombreuses .
rem: pourquoi 2 colonnes mois/jour ? une seule suffit en format date

P.
 

Pièces jointes

  • ExempleSousTotal kabamel-xld.xls
    276 KB · Affichages: 45
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
Bonjour,

non ce n'est pas clair du tout..
tu n'utilises pas le bon langage je pense..
fusion au lieu de filtrer ?
colonne au lieu de ligne

ha pardon. je viens de voir ta macro. tu sembles vouloir "Grouper" des lignes.. plutot que fusionner..

par contre, je ne sais pas du tout quel sous total tu souhaites. et ou..

voir PJ pour un début de piste
onglet Data:
les mois et Jours pour liste de validation pour le choix des cellules jaunes
puis les sous totaux pour les colonnes Nbr Agent.. Alloc.
 

Pièces jointes

  • ExempleSousTotal.xls
    185 KB · Affichages: 40
Vote positif 0 Vote négatif
K

kabamel

XLDnaute Occasionnel
Excusé moi de la petite erreur, au faite c'est la colonne A et C qui sont concernées, Je mets encore un fichier dans lequel j'ai mis une feuille "ResultatAttendu" après exécution de ma macro, En colonne C il y a des sommes par zone maintenant je dois faire un arrêt en colonne A qui me donnera le total des sommes dans la colonne C. Je ne sais pas si je me fais comprendre.
 

Pièces jointes

  • ExempleSousTotal.xls
    444 KB · Affichages: 38
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
Re
bon. je viens de regarder ta macro. en voici une autre version. qui fonctionne; enfin... je pense

Code: 
Sub SousTotaux3()
Dim i As Long
Dim Iprec As Long
Dim strNom, strNom2 As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'i = 2
NbLignes = Range("A" & Rows.Count).End(xlUp).Row
'Boucle sur tant que la colonne A n'est pas vide

For i = NbLignes To 2 Step -1
    'Si nom de la ligne <> du nom precedent
    j = i
    While Range("A" & j).Value = Range("A" & i).Value And Range("C" & j).Value = Range("C" & i).Value
        j = j - 1
    Wend
    Rows(i + 1).Insert
  
    Range("E" & i + 1).FormulaLocal = "=somme(E" & j + 1 & ":E" & i & ")"
    Range("F" & i + 1).FormulaLocal = "=somme(F" & j + 1 & ":F" & i & ")"
    Range("G" & i + 1).FormulaLocal = "=somme(G" & j + 1 & ":G" & i & ")"
    Range("H" & i + 1).FormulaLocal = "=somme(H" & j + 1 & ":H" & i & ")"
    Range("I" & i + 1).FormulaLocal = "=somme(I" & j + 1 & ":I" & i & ")"
      
    'Ajoute le nom en B et C
    Range("A" & i + 1).Value = Range("A" & j + 1).Value
    Range("C" & i + 1).Value = Range("C" & j + 1).Value
    Range("A" & i + 1 & ":I" & i + 1).Font.Bold = True
    'Regroupe les lignes et les fusionnes
    Rows(j + 1 & ":" & i).Group
    Range("C" & j + 1 & ":C" & i + 1).Merge
    i = j + 1
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

à noter que lorsqu'on ajoute des lignes. il vaut toujours mieux commencer par le bas..
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
Code: 
Sub SousTotaux3()
Dim i As Long
Dim Iprec As Long
Dim strNom, strNom2 As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'i = 2
nbLignes = Range("A" & Rows.Count).End(xlUp).Row
'Boucle sur tant que la colonne A n'est pas vide

FinMois = nbLignes
For i = nbLignes To 1 Step -1
    'si on change de mois
    If Range("A" & i) <> Range("A" & i + 1) And i <> nbLignes Then
        DebMois = i + 1
        Rows(FinMois + 1).Insert
        Range("E" & FinMois + 1).FormulaLocal = "=somme(E" & DebMois & ":E" & FinMois & ")"
        Range("F" & FinMois + 1).FormulaLocal = "=somme(F" & DebMois & ":F" & FinMois & ")"
        Range("G" & FinMois + 1).FormulaLocal = "=somme(G" & DebMois & ":G" & FinMois & ")"
        Range("H" & FinMois + 1).FormulaLocal = "=somme(H" & DebMois & ":H" & FinMois & ")"
        Range("I" & FinMois + 1).FormulaLocal = "=somme(I" & DebMois & ":I" & FinMois & ")"
        Range("A" & FinMois + 1).Value = Range("A" & DebMois).Value
        Range("C" & FinMois + 1).Value = "All Services"
        Rows(DebMois & ":" & FinMois).Group
        FinMois = DebMois - 1
    End If
    'Si nom de la ligne <> du nom precedent
    j = i
    If j = 0 Then Exit Sub
    While Range("A" & j).Value = Range("A" & i).Value And Range("C" & j).Value = Range("C" & i).Value
        j = j - 1
    Wend
    Rows(i + 1).Insert
    FinMois = FinMois + 1
  
    Range("E" & i + 1).FormulaLocal = "=somme(E" & j + 1 & ":E" & i & ")"
    Range("F" & i + 1).FormulaLocal = "=somme(F" & j + 1 & ":F" & i & ")"
    Range("G" & i + 1).FormulaLocal = "=somme(G" & j + 1 & ":G" & i & ")"
    Range("H" & i + 1).FormulaLocal = "=somme(H" & j + 1 & ":H" & i & ")"
    Range("I" & i + 1).FormulaLocal = "=somme(I" & j + 1 & ":I" & i & ")"
      
    'Ajoute le nom en B et C
    Range("A" & i + 1).Value = Range("A" & j + 1).Value
    Range("C" & i + 1).Value = Range("C" & j + 1).Value
    Range("A" & i + 1 & ":I" & i + 1).Font.Bold = True
    'Regroupe les lignes et les fusionnes
    Rows(j + 1 & ":" & i).Group
    Range("C" & j + 1 & ":C" & i + 1).Merge
    i = j + 1
Next i
  
  
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
oui j'ai vu ca depuis. , c'est lorsque la variable "j" arrive à 0..
voici le correctif.

Code: 
Sub SousTotaux3()
Dim i As Long
Dim Iprec As Long
Dim strNom, strNom2 As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'i = 2
nbLignes = Range("A" & Rows.Count).End(xlUp).Row
'Boucle sur tant que la colonne A n'est pas vide

FinMois = nbLignes
For i = nbLignes To 1 Step -1
    'si on change de mois
    If Range("A" & i) <> Range("A" & i + 1) And i <> nbLignes Then
        DebMois = i + 1
        Rows(FinMois + 1).Insert
        Range("E" & FinMois + 1).FormulaLocal = "=somme(E" & DebMois & ":E" & FinMois & ")"
        Range("F" & FinMois + 1).FormulaLocal = "=somme(F" & DebMois & ":F" & FinMois & ")"
        Range("G" & FinMois + 1).FormulaLocal = "=somme(G" & DebMois & ":G" & FinMois & ")"
        Range("H" & FinMois + 1).FormulaLocal = "=somme(H" & DebMois & ":H" & FinMois & ")"
        Range("I" & FinMois + 1).FormulaLocal = "=somme(I" & DebMois & ":I" & FinMois & ")"
        Range("A" & FinMois + 1).Value = "TOTAL " & Range("A" & DebMois).Value
        Range("C" & FinMois + 1).Value = "All Services"
        Rows(DebMois & ":" & FinMois).Group
        FinMois = DebMois - 1
    End If
    'Si nom de la ligne <> du nom precedent
    j = i
    'If j = 0 Then Exit Sub
    While Range("A" & j).Value = Range("A" & i).Value And Range("C" & j).Value = Range("C" & i).Value
        j = j - 1
        If j = 0 Then Exit Sub
    Wend
    Rows(i + 1).Insert
    FinMois = FinMois + 1
   
    Range("E" & i + 1).FormulaLocal = "=somme(E" & j + 1 & ":E" & i & ")"
    Range("F" & i + 1).FormulaLocal = "=somme(F" & j + 1 & ":F" & i & ")"
    Range("G" & i + 1).FormulaLocal = "=somme(G" & j + 1 & ":G" & i & ")"
    Range("H" & i + 1).FormulaLocal = "=somme(H" & j + 1 & ":H" & i & ")"
    Range("I" & i + 1).FormulaLocal = "=somme(I" & j + 1 & ":I" & i & ")"
       
    'Ajoute le nom en B et C
    Range("A" & i + 1).Value = Range("A" & j + 1).Value
    Range("C" & i + 1).Value = Range("C" & j + 1).Value
    Range("A" & i + 1 & ":I" & i + 1).Font.Bold = True
    'Regroupe les lignes et les fusionnes
    Rows(j + 1 & ":" & i).Group
    Range("C" & j + 1 & ":C" & i + 1).Merge
    i = j + 1
Next i
   
   
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
K

kabamel

XLDnaute Occasionnel
Désolé de vs embêter, problème au niveau du total par mois tous services confondus.
1) Le premier truc, c'est de faire la somme par service, notons cette somme par X
2) la total des mois sera la somme des X
il y a trois service pour chaque mois donc il y aura trois somme, le total de ces sommes est l'arrêt du mois
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
1) Le premier truc, c'est de faire la somme par service, notons cette somme par X
Cliquez pour agrandir...

euh.. qu'est ce que t'avais pas compris dans ma question:
un sous total par mois.. tous services confondus? ou par mois et par service. ?
Cliquez pour agrandir...

bon.. la. va falloir passer par un TCD.. ce sera quand meme plus simple et plus rapide
ou alors. avec la formule Sommeprod comme proposée au tout début

Voir PJ avec les différentes solutions
 

Pièces jointes

  • ExempleSousTotal (2).xls
    814 KB · Affichages: 60
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
nouvelle proposition qui groupe les mois: c'est un intermédiaire entre le TCD et le groupement service par service et mois par mois
ici. seuls les mois sont groupés. par contre. tu as les Totaux par service.
Code: 
Sub SousTotaux4()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Libellé1 = "SERVICES CENTRAUX"
Libellé2 = "SERVICES DÉCONCENTRÉS INTÉRIEUR"
Libellé3 = "SERVICES DÉCONCENTRÉS CONAKRY"
Libellé4 = "All Services"

'on récupère le nombre total de lignes
nbLignes = Range("A" & Rows.Count).End(xlUp).Row

'on commence par séparer tous les mois
FinMois = nbLignes
For i = nbLignes To 1 Step -1
    If Range("A" & i) <> Range("A" & i + 1) And Range("A" & i + 1) <> "" Then
        'on insère 4 lignes pour y placer les totaux
        Rows(i + 1).Insert
        Rows(i + 1).Insert
        Rows(i + 1).Insert
        Rows(i + 1).Insert
      
        'Mise à jour de la ligne de fin de mois
        FinMois = FinMois + 4
        'Mise à jour de la ligne de début de mois
        DebMois = i + 5
      
        'on écrit les formules
        formuleETotalMois = "=somme(E" & DebMois & ":E" & FinMois & ")"
        formuleELibelle1 = "=sommeprod(($C" & DebMois & ":$C" & FinMois & "=""" & Libellé1 & """)*(E" & DebMois & ":E" & FinMois & "))"
        formuleELibelle2 = "=sommeprod(($C" & DebMois & ":$C" & FinMois & "=""" & Libellé2 & """)*(E" & DebMois & ":E" & FinMois & "))"
        formuleELibelle3 = "=sommeprod(($C" & DebMois & ":$C" & FinMois & "=""" & Libellé3 & """)*(E" & DebMois & ":E" & FinMois & "))"
              
        'on les place dans les cellules en fin de mois
        Range("E" & FinMois + 1).FormulaLocal = formuleETotalMois
        Range("E" & FinMois + 2).FormulaLocal = formuleELibelle1
        Range("E" & FinMois + 3).FormulaLocal = formuleELibelle2
        Range("E" & FinMois + 4).FormulaLocal = formuleELibelle3
      
        'on étire les formules jusqu'à la colonne I
        Range("E" & FinMois + 1 & ":I" & FinMois + 4).FillRight
      
        'on place les labels
        Range("A" & FinMois + 1) = "Total " & Range("A" & FinMois)
        Range("C" & FinMois + 2) = "Total " & Libellé1
        Range("C" & FinMois + 3) = "Total " & Libellé2
        Range("C" & FinMois + 4) = "Total " & Libellé3
      
        'on insère une nouvelle ligne pour séparer les mois
        Rows(FinMois + 5).Insert
      
        'on groupe le mois
        Rows(DebMois & ":" & FinMois).Group
        FinMois = i
    End If
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

W
  • Question
Microsoft 365 Fusionne les cellules vides parmi celle avec des valeurs
Réponses
4
Affichages
247
woira95
W
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
B
  • Question
XL 2019 calendrier horaire travail
Réponses
9
Affichages
469
Bsm
B
E
  • Question
XL 2016 Calcul cellules vides sous conditions multiples
Réponses
8
Affichages
349
DJunqueira
D
S
  • Résolu(e)
Microsoft 365 Vba, Mise en forme d'un calendrier
Réponses
8
Affichages
139
SOP
S
C
  • Résolu(e)
XL 2013 Sous-total erroné
Réponses
6
Affichages
377
chris
chris
A
  • Question
XL 2019 Filtre avancé en VBA
Réponses
12
Affichages
386
Amilo
A
L
  • Question
Autres Macro pour conevrtir des lignes excel en CSV
Réponses
3
Affichages
190
sylvanu
sylvanu
oguruma
POWERQUERY :: Faire la somme d'un tableau horizontalement et verticalement (somme des lignes, somme des colonnes)
Réponses
0
Affichages
214
oguruma
oguruma
P
  • Question
Microsoft 365 Supprimer sous-totaux négatifs dans une liste
Réponses
10
Affichages
400
djidji59430
djidji59430

Membres actuellement en ligne

1 membres et 30 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 453
Messages
2 088 550
Membres
103 881
dernier inscrit
malbousquet