Insérer ligne sous-total automatiquement

[Alice_S]

Bonjour à tous,

Voici mon souci, j'ai un tableau suivi horaire pour une personne avec à la fin de chaque semaine un sous-total, j'ai insérer manuellement la ligne en plus et la fonction SOUS.TOTAL. J'aurais aimé savoir s'il existait une macro permettant cela ? J'ai cherché et testé quelques macros trouvées sur ce forum sans que cela corresponde réellement.

En vous remerciant par avance.

Cdt.

 

[pierrejean]

Re : Insérer ligne sous-total automatiquement

Bonjour Alice_S

A tester:

Sub SousTotaux()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each sh In Sheets
 If sh.Name <> "Shynthèse" Then
   x = sh.Range("B" & Rows.Count).End(xlUp).Row
   ldeb = 4
   For n = 6 To x - 1
     If sh.Range("B" & n).Value = "Dimanche" Then
       sh.Range("G" & n + 1) = "Sous-total"
       sh.Range("H" & n + 1).FormulaLocal = "=SOUS.TOTAL(9;H" & ldeb & ":H" & n & ")"
       sh.Range("I" & n + 1).FormulaLocal = "=SOUS.TOTAL(9;I" & ldeb & ":I" & n & ")"
       sh.Range("J" & n + 1).FormulaLocal = "=SOUS.TOTAL(9;J" & ldeb & ":J" & n & ")"
       ldeb = n + 2
     End If
   Next
     If sh.Range("G" & x) <> "Dimanche" Then
       sh.Range("G" & x + 1) = "Sous-total"
       sh.Range("H" & x + 1).FormulaLocal = "=SOUS.TOTAL(9;H" & ldeb & ":H" & x - 1 & ")"
       sh.Range("I" & x + 1).FormulaLocal = "=SOUS.TOTAL(9;I" & ldeb & ":I" & x - 1 & ")"
       sh.Range("J" & x + 1).FormulaLocal = "=SOUS.TOTAL(9;J" & ldeb & ":J" & x - 1 & ")"
     End If
 End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[job75]

Re : Insérer ligne sous-total automatiquement

Bonsoir Alice, salut Pierre

Une autre manière :

Sub SousTotaux()
Dim w As Worksheet, plage As Range, zone1 As Range
Dim zone2 As Range, C As Range, i As Byte, j As Byte
Dim z1 As Range, z2 As Range, a As String
Application.ScreenUpdating = False
For Each w In Worksheets
  If IsDate("1 " & w.Name) Then
    Set plage = w.Range("B4", w.[B65536].End(xlUp)(2))
    Set zone1 = plage.SpecialCells(xlCellTypeFormulas).EntireRow
    Set zone2 = plage.SpecialCells(xlCellTypeBlanks).EntireRow
    Set C = w.[G:J]
    Intersect(zone2, C.Columns(1)) = "Sous-total"
    For i = 2 To C.Columns.Count
      For j = 1 To zone1.Areas.Count
        Set z1 = Intersect(zone1.Areas(j), C.Columns(i))
        Set z2 = Intersect(zone2.Areas(j), C.Columns(i))
        z2.Formula = "=SUBTOTAL(9," & z1.Address(0, 0) & ")"
      Next
      a = Intersect(plage.EntireRow, C.Columns(i)).Address(0, 0)
      z2(2).Formula = "=SUBTOTAL(9," & a & ")"
      If i = 2 Then z2(2, 0) = "Total"
    Next
  End If
Next
End Sub

Fichier joint.

Nota 1 : la macro traite aussi la ligne "Total".

Nota 2 : il manquait un accent aigu au nom de l'onglet "Décembre", il est indispensable ici.

Nota 3 : je ne me suis pas occupé de la mise en forme, police "Gras" et format heure.

C'est facile à ajouter si nécessaire.

Nota 4 : j'ai modifié la macro FiltrerEffacer : le bas du tableau est déterminé par la colonne I.

A+

 

[job75]

Re : Insérer ligne sous-total automatiquement

Re,

J'avais écrit For j = 2 pour la 2ème boucle, j'ai corrigé le fichier.

A+

 

[job75]

Re : Insérer ligne sous-total automatiquement

Re,

Sur ce fichier (2) j'ai ajouté les formats "Gras" et [h]:mm.

A+