insertion automatique ligne ss sous totaux

  • Initiateur de la discussion barbara
  • Date de début
B

barbara

Guest
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]
 

Pièces jointes

  • Classeur2_20060422210133.zip
    19.8 KB · Affichages: 32

_Thierry

XLDnaute Barbatruc
Repose en paix
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:D').EntireColumn.Hidden =
False
        .UsedRange.RemoveSubtotal
        .Range('A2:d300').Clear
   
End With
End Sub

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

Discussions similaires

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh