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.
Sous-total en VBA
- Initiateur de la discussion kabamel
- Date de début
Salut, En remplaçant la formule somme par la formule Sous-Total, cela peut changer quelque chose ?
vgendron, Je suis vraiment content de l'aide que vous m'apportiez, je vous mets encore un autre fichier dans lequel il y a une feuille "ResultatAttendu", j'ai appliqué le sous-total d'excel, c'est le même resultat que je veux obtenir. Merci
vgendron
XLDnaute Barbatruc
essaie ceci
Code:
Sub COMPLET()
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 = "TOTAL GENERAL"
'on récupère le nombre total de lignes
nbLignes = Range("A" & Rows.Count).End(xlUp).Row
'on groupe l'ensemble
Rows(2 & ":" & nbLignes).Group
'la formule pour le total général
formuleETotalGeneral = "=SOUS.TOTAL(9;E2" & ":E" & nbLignes & ")"
'on peut déjà placer le total général -Libelle, formule et étire
Range("A" & nbLignes + 1) = Libellé4
Range("E" & nbLignes + 1).FormulaLocal = formuleETotalGeneral
Range("E" & nbLignes + 1 & ":I" & nbLignes + 1).FillRight
Range("A" & nbLignes + 1 & ":I" & nbLignes + 1).Font.Bold = True
'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) <> "TOTAL GENERAL" Then
'Mise à jour de la ligne de début de mois
DebMois = i + 1
'on construit la formule
formuleETotalMois = "=SOUS.TOTAL(9;E" & DebMois & ":E" & FinMois & ")"
'on la place dans la cellule en fin de mois
Rows(FinMois + 1).Insert
Range("E" & FinMois + 1).FormulaLocal = formuleETotalMois
'on étire la formule jusqu'à la colonne I
Range("E" & FinMois + 1 & ":I" & FinMois + 1).FillRight
'on place le label
Range("A" & FinMois + 1) = "Total " & Range("A" & FinMois)
'on groupe le mois
Rows(DebMois & ":" & FinMois).Group
'********************************************************
'groupement interne par service
FinService = FinMois
For j = FinMois To DebMois Step -1
While Range("C" & j).Value = Range("C" & j - 1).Value And Range("A" & j).Value = Range("A" & j - 1).Value
j = j - 1
If j = 0 Then Exit Sub
Wend
'on insère une ligne en fin de service
Rows(FinService + 1).Insert
'on colle la formule et on étire
Range("E" & FinService + 1).FormulaLocal = "=SOUS.TOTAL(9;E" & j & ":E" & FinService & ")"
Range("E" & FinService + 1 & ":I" & FinService + 1).FillRight
'Ajoute le nom du service en C avec TOTAL - en gras
Range("C" & FinService + 1).Value = "TOTAL " & Range("C" & FinService).Value
Range("C" & FinService + 1 & ":I" & FinService + 1).Font.Bold = True
'Regroupe les lignes
Rows(j & ":" & FinService).Group
'Range("C" & j + 1 & ":C" & i + 1).Merge
FinService = j - 1
Next j
'********************************************************
FinMois = i
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End SubWaouh, Excellent, un moment j'ai cru qu'il était impossible de faire une telle chose, et voilà, Merci beaucoup
Une dernière chose, je veux fusionné les cellules identiques en colonne A jusqu'au total du mois ainsi que la colonne C jusqu'au total de chaque service
Une dernière chose, je veux fusionné les cellules identiques en colonne A jusqu'au total du mois ainsi que la colonne C jusqu'au total de chaque service
vgendron
XLDnaute Barbatruc
Code:
Sub COMPLET()
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 = "TOTAL GENERAL"
'on récupère le nombre total de lignes
nbLignes = Range("A" & Rows.Count).End(xlUp).Row
'on groupe l'ensemble
Rows(2 & ":" & nbLignes).Group
'la formule pour le total général
formuleETotalGeneral = "=SOUS.TOTAL(9;E2" & ":E" & nbLignes & ")"
'on peut déjà placer le total général -Libelle, formule et étire
Range("A" & nbLignes + 1) = Libellé4
Range("E" & nbLignes + 1).FormulaLocal = formuleETotalGeneral
Range("E" & nbLignes + 1 & ":I" & nbLignes + 1).FillRight
Range("A" & nbLignes + 1 & ":I" & nbLignes + 1).Font.Bold = True
'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) <> "TOTAL GENERAL" Then
'Mise à jour de la ligne de début de mois
DebMois = i + 1
'on construit la formule
formuleETotalMois = "=SOUS.TOTAL(9;E" & DebMois & ":E" & FinMois & ")"
'on la place dans la cellule en fin de mois
Rows(FinMois + 1).Insert
Range("E" & FinMois + 1).FormulaLocal = formuleETotalMois
'on étire la formule jusqu'à la colonne I
Range("E" & FinMois + 1 & ":I" & FinMois + 1).FillRight
'on place le label
Range("A" & FinMois + 1) = "Total " & Range("A" & FinMois)
'on groupe le mois, on merge et centre
Rows(DebMois & ":" & FinMois).Group
'********************************************************
'groupement interne par service
FinService = FinMois
For j = FinMois To DebMois Step -1
While Range("C" & j).Value = Range("C" & j - 1).Value And Range("A" & j).Value = Range("A" & j - 1).Value
j = j - 1
If j = 0 Then Exit Sub
Wend
'on insère une ligne en fin de service
Rows(FinService + 1).Insert
FinMois = FinMois + 1
'on colle la formule et on étire
Range("E" & FinService + 1).FormulaLocal = "=SOUS.TOTAL(9;E" & j & ":E" & FinService & ")"
Range("E" & FinService + 1 & ":I" & FinService + 1).FillRight
'Ajoute le nom du service en C avec TOTAL - en gras
Range("C" & FinService + 1).Value = "TOTAL " & Range("C" & FinService).Value
Range("C" & FinService + 1 & ":I" & FinService + 1).Font.Bold = True
'Regroupe les lignes
Rows(j & ":" & FinService).Group
Range("C" & j & ":C" & FinService).Merge
Range("C" & j & ":C" & FinService).HorizontalAlignment = xlCenter
Range("C" & j & ":C" & FinService).VerticalAlignment = xlCenter
FinService = j - 1
Next j
Range("A" & DebMois & ":A" & FinMois).Merge
Range("A" & DebMois & ":A" & FinMois).HorizontalAlignment = xlCenter
Range("A" & DebMois & ":A" & FinMois).VerticalAlignment = xlCenter
'********************************************************
FinMois = i
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End SubDiscussions similaires
