Sous-total en VBA

[kabamel]

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.

 

[gosselien]

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.

 

[kabamel]

Merci pour ta réponse rapide, effectivement j'ai pensé à faire un TCD mais ce qu'il me faut c'est de le faire en vba. Merci d'avoir essayé.

 

[vgendron]

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.

 

[kabamel]

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.

 

[vgendron]

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

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..

 

[kabamel]

Oui une solution encore, mais il reste l'arrêt par mois, qui est le total des sommes obtenu dans la colonne C au cour de ce mois. Merci d'avoir essayer

 

[vgendron]

mais il reste l'arrêt par mois,

un sous total par mois.. tous services confondus? ou par mois et par service. ?

 

[kabamel]

un sous total par mois.. tous services confondus

 

[vgendron]

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

 

[kabamel]

Une erreur se produit à cette ligne :

    While Range("A" & j).Value = Range("A" & i).Value And Range("C" & j).Value = Range("C" & i).Value

 

[vgendron]

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

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

 

[kabamel]

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

 

[vgendron]

1) Le premier truc, c'est de faire la somme par service, notons cette somme par X

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. ?

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

 

[vgendron]

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.

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