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

Charloooon · 18 Septembre 2019

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

VB:

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 · 16 Novembre 2019

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

VB:

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 · 16 Novembre 2019

Bonjour Charloooon, JM,

Les 2 macros :

VB:

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 · 16 Novembre 2019

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 :

VB:

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 · 16 Novembre 2019

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 · 16 Novembre 2019

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

Staple1600 · 16 Novembre 2019

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 · 16 Novembre 2019

Staple1600 à dit:
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 · 27 Novembre 2019

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

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

Charloooon

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Charloooon

XLDnaute Nouveau

Discussions similaires