insertion automatique ligne ss sous totaux

[barbara]

Bonjour,

A partir de données filtrées(selon valeur de la cellule F1 de la feuille1), des sous-totaux sont générés, il y a une mise en forme qui se fait mais j'aimerais aussi insérer une ligne sous chaque sous-total

merci à tous ceux qui prendront le temps de me répondre

barbara [file name=Classeur2_20060422210133.zip size=20238]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Classeur2_20060422210133.zip[/file]

 

[_Thierry]

Bonsoir Barbara, le Forum

Voici ton module quelque peu remanié, tout en conservant la structure de base de tes macros. Dans l'ensemble c'était assez bien.

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

Bonne Soirée
[ol]@+Thierry[/ol]

 

[Barbara]

Bonsoir Thierry,

Merci d'avoir résolu mon problème et aussi pour les 'réaménagements'.Effectivement c'est mieux structuré comme cela

bonne soirée
Barbara