insertion automatique ligne ss sous totaux

Option Explicit

Sub Bouton()
Application.ScreenUpdating = False

Call Reinitialiser
Call Filtrer
Call Mise_En_Forme
Application.ScreenUpdating = True
'Sheets('SIIG').Activate

End Sub

Sub Filtrer()
Dim WS As Worksheet

Set WS = Sheets('SIIG')

    With WS
    .Activate
        If .AutoFilterMode Then
            .AutoFilterMode = False
            .Range('D2').AutoFilter Field:=4, Criteria1:=Range('F1')
        Else
            .Range('D2').AutoFilter Field:=4, Criteria1:=Range('F1')
        End If

        .Range('A2').CurrentRegion.Copy Destination:=Sheets('details').Range('A1')
    End With
   
Call Sous_Totaux
End Sub
Sub Sous_Totaux()
Dim WS As Worksheet

Set WS = Sheets('Details')

WS.Activate

Range('A2').CurrentRegion.Subtotal GroupBy:=1, _
                                    Function:=xlSum, _
                                    TotalList:=Array(3), _
                                    Replace:=True, _
                                    PageBreaks:=False, _
                                    SummaryBelowData:=True

Columns('d:d').EntireColumn.Hidden = True



End Sub

Sub Mise_En_Forme()
Dim DLD As Integer
Dim R As Integer

DLD = Sheets('Details').Range('A65536').End(xlUp).Row

    For R = DLD To 2 Step -1
        If Range('A' & R).Value Like 'Total*' = True Then
           
            With Range('A' & R & ':C' & R)
            .Font.Bold = True
                With .Interior
                    .ColorIndex = 15
                    .Pattern = xlSolid
                End With
            .Style = 'Comma'
            End With
           
            Rows(R + 1).Insert Shift:=xlShiftDown
            Rows(R + 1).Interior.ColorIndex = xlNone
           
        End If
    Next R

ActiveWindow.ScrollRow = 1
End Sub

Sub Reinitialiser()
    With Sheets('Details')
        .Range('D').EntireColumn.Hidden = False
        .UsedRange.RemoveSubtotal
        .Range('A2:d300').Clear
    End With
End Sub

Cliquez pour agrandir...