Microsoft 365 macro insérer ligne sous-total et changer la couleur et bordure

[Charloooon]

Bonjours a tous!

Jai besoin d'un petit coups de pouce!

ma macro présentement ce quelle réalise:
ajoute une ligne entre chaque changement de métier (en dessous) dans la colonne A.
ajout "sous-total" en colonne E.
calcule la somme de chaque métier, colonne i.
Color la première ligne de chaque métier, colonne A.

Ce que aimerais modifier :
ajoute une ligne entre chaque changement de métier (au dessus) dans la colonne A.
Dans cette nouvelle ligne, Répéter le métier en colonne A et calculer le sous- somme en colonne i ,
et supprimer les bordure entre.

Bonne Journée À Tous ! merci à lavance pour votre aide

Option Explicit
Sub aSubTotal2()
Dim iCol As Integer
Dim i As Integer
Dim j As Integer

Application.ScreenUpdating = False
j = i

Range("a2").CurrentRegion.Offset(1).Sort Range("a3"), 1
    Do While Range("a" & i) <> ""
    If Range("a" & i) <> Range("a" & (i - 1)) Then
     Rows(i + 1).Insert
     Range("A" & j & ":i" & j).Interior.Color = 5287936
    Range("b" & (i + 1)) = "" & Range("a" & i).Value
    iCol = 9
      Cells(i - 1, iCol).Formula = "=SUM(R" & j & "C:R" & i & "C)"
    Range(Cells(i + 1, 1), Cells(i + 1, 9)).Font.Bold = True
            i = i + 2
            j = i
        Else
            i = i + 1
        End If
    Loop
Application.ScreenUpdating = True
End Sub
-----------------------------------------------------
Sub Restore2()
 
   [a2:A100].SpecialCells(4).EntireRow.Delete
End Sub

 

[Staple1600]

Bonjour le fil, Charloooon

Charloooon
Je passais par là, j'ai vu de la lumière, alors je suis entré
Une proposition en utilisant la fonctionnalité prévu par Excel pour les sous-totaux

Sub aSubTotal3()
Application.ScreenUpdating = False
With Range(Cells(1), Cells(Rows.Count, "I").End(3))
  .Subtotal _
      GroupBy:=1, _
      Function:=xlSum, _
      TotalList:=Array(9), _
      Replace:=False, PageBreaks:=True, SummaryBelowData:=False
   ActiveSheet.Outline.ShowLevels RowLevels:=2
   .SpecialCells(xlCellTypeVisible).Interior.Color = 5287936
End With
ActiveSheet.Outline.ShowLevels RowLevels:=3: Rows("1:2").Interior.Color = xlNone
End Sub
Sub Restore3()
With Range(Cells(1), Cells(Rows.Count, "I").End(3))
  .ClearOutline
  .RemoveSubtotal
End With
End Sub

 

[job75]

Bonjour Charloooon, JM,

Les 2 macros :

Sub SousTotal()
Dim i&, n&
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Sort [A1], xlAscending, Header:=xlYes 'tri préalable
With [A1].CurrentRegion
    For i = .Rows.Count - 1 To 1 Step -1
        If .Cells(i, 1) <> .Cells(i + 1, 1) Then
            .Rows(i + 1).Insert xlDown
            With .Rows(i + 1)
                .Clear 'efface les formats
                .Cells(2, 9).Copy .Cells(9) 'copie le format en colonne I
                .Interior.Color = 5287936 'vert
                .Font.Bold = True 'gras
                .Borders.LineStyle = xlNone
                n = Application.CountIf(.Cells(1).EntireColumn, .Cells(2, 1))
                If n Then .Cells(9) = "=SUM(" & .Cells(2, 9).Resize(n).Address(0, 0) & ")"
                .Cells(1) = .Cells(2, 1)
            End With
        End If
    Next
End With
End Sub

Sub Retablir()
On Error Resume Next 'si aucune SpecialCell
[I:I].SpecialCells(xlCellTypeFormulas).EntireRow.Delete
End Sub

A+

 

[job75]

S'il y a des "trous" (cellules vides) en colonne A la macro précédente ne va pas bien, voyez plutôt celle-ci dans le fichier joint :

Sub SousTotal()
Dim nlig&, i&, n&
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Sort [A1], xlAscending, Header:=xlYes 'tri préalable
With [A1].CurrentRegion
    nlig = .Rows.Count
    For i = nlig To 2 Step -1
        If .Cells(i, 1) <> .Cells(i - 1, 1) Then
            .Rows(i).Insert xlDown
            With .Rows(i)
                .Clear 'efface les formats
                .Cells(2, 9).Copy .Cells(9) 'copie le format en colonne I
                .Interior.Color = 5287936 'vert
                .Font.Bold = True 'gras
                n = Application.CountIf(.Cells(1).EntireColumn, .Cells(2, 1))
                If n = 0 Then n = nlig - i + 1
                .Cells(9) = "=SUM(" & .Cells(2, 9).Resize(n).Address(0, 0) & ")"
                .Cells(1) = .Cells(2, 1)
            End With
        End If
    Next
End With
End Sub

 

[Staple1600]

Bonjour le fil, job75

job75
Je suppose qu'il y a une anguille sous roche dans le fait d'utiliser ici en VBA Range("X").SubTotal, non ?

 

[job75]

Je ne vois pas d'anguille sous roche JM, ta macro marche très bien à condition que le tableau soit préalablement trié.

 

[Staple1600]

Re

job75
C'est donc ce pré-requis (le tri) qui explique que tu n'utilises pas cette fonction native d'Excel
Function Subtotal(GroupBy As Long, Function As XlConsolidationFunction, TotalList, [Replace], [PageBreaks], [SummaryBelowData As XlSummaryRow = xlSummaryBelow])
Ou c'est simplement : "Des goûts et des couleurs on ne discute pas" ?

 

[job75]

C'est donc ce pré-requis (le tri) qui explique que tu n'utilises pas cette fonction native d'Excel

Pas du tout, c'est simplement que ce genre de fonction est trop compliqué pour moi et sans doute pour beaucoup d'autres.

 

[Charloooon]

MERCI à tous d'avoir répondu ! d'avantage a job75 ça marches à merveille