Insérer un total sous les données

**Prekestolen** · 15/04/2009, 21h28

Bonjour à tous

Ma question peut sembler idiote aux premiers abords, mais elle me cause un problème puisque je suis un novice en programmation. Passons vite au chose sérieuse voici mon code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
 Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1:F1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
    Selection.Merge
    Range("G2").Select
    Selection.Copy
    Range("A1:F1").Select
    ActiveSheet.Paste
    Range("A1:F1000").Select
    Range("F1000").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Cells.Select
    Application.CutCopyMode = False
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5, 6), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
 
     'ajout
     Range("A1").Select
     Selection.Font.Bold = True
     Selection.Font.ColorIndex = 3
     Selection.Font.Underline = xlUnderlineStyleSingle
     Rows("1:1").RowHeight = 26.25
     Range("A2:F2").Select
     Selection.Font.Bold = True
     Selection.Font.ColorIndex = 11
    'fin ajout
 
    '**************Ajout de code pour placer une ligne vide
Dim max As Long
Dim indice As Long
Dim flag_total As Boolean
 
flag_total = False
indice = 2
 
max = ActiveSheet.Range("A1000").End(xlUp).Row 'pas besoin de plus que 1000
Do While indice < max + 1
 
 Select Case True
        Case flag_total
            'fin ajout
            Rows(indice).Insert Shift:=xlDown
            flag_total = False
            max = max + 1
        Case UCase(Left(Range("A" & indice), 5)) = "TOTAL"
            flag_total = True
            'Nouvel ajout pour le caractère gras
            Rows(indice).Font.Bold = True
        Case Else
 End Select
indice = indice + 1
Loop
 
 
'****************fin de code
 
    'Cette ligne sert à cliquer sur le petit 2 dans le carré à gauche pour le sommaire
    ActiveSheet.Outline.ShowLevels RowLevels:=2
   ' sert à mettre les colonnes de la bonne largeur
    Columns("A:A").ColumnWidth = 33.29
    Columns("B:B").ColumnWidth = 13#
    Columns("C:C").ColumnWidth = 17#
    Columns("D:D").ColumnWidth = 7.86
    Columns("E:E").ColumnWidth = 17#
    Columns("F:F").ColumnWidth = 8.43
      Columns("E:E").Select
    Range("E11").Activate
    Selection.NumberFormat = "0.00"
    Columns("F:F").Select
    Range("F11").Activate
    Selection.NumberFormat = "0.00"
 
       Sheets("Feuil2").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Feuil3").Select
    ActiveWindow.SelectedSheets.Delete
 
    '*************AJOUT POUR METTRE LA FEUILLE EN PAYSAGE
    With ActiveSheet.PageSetup
 
        .Orientation = xlLandscape
 
    End With
    '******************FIN PAYSAGE
    Range("G1").Select

Donc ce que cela fait c'est que j'ai un peu codé la fonction Excel
Données Sous-totaux pour que cela se fasse automatiquement.
J'ai mis 1000 comme maximum de ligne (car je ne sais jamais d'un mois à l'autre combien de ligne ca va me prendre), donc il va me planter le total final à la fin au lieu de la planter après la dernière donnée.
Quelqu'un(e) a-t-il(elle) une idée?

**JPierreM** · 16/04/2009, 08h40

J'ai commencé à regarder ton code
c'est compliqué

Je l'ai allégé car de nombreuses choses sont inutiles
les valeurs par défaut du format sont inutiles puisque par défaut
les selections sont souvent inutiles

je me suis arrêté à : '**************Ajout de code pour placer une ligne vide
Sans aller + loin je pense qu'il y a problème puisque la ligne pour les titres dans ta feuille de sous totaux sera la cellule A1 que tu as fusionné au début de ton code Range("A1:F1").Merge

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1:F1").Merge 'Select
'    With Selection
'        .HorizontalAlignment = xlCenter
'        .VerticalAlignment = xlTop
'        .WrapText = False
'        .Orientation = 0
'        .AddIndent = False
'        .IndentLevel = 0
'        .ShrinkToFit = False
'        .ReadingOrder = xlContext
'        .MergeCells = False
'    End With
 
    'Selection.Merge
    'Range("G2").Select
    'Selection.Copy
    'Range("A1:F1").Select
    'ActiveSheet.Paste
    Range("A1") = Range("G2")
    'Range("A1:F1000").Select
    'Range("F1000").Activate
    'Application.CutCopyMode = False
    'Selection.Copy
    Range("A1:F1000").Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   ''''' Cells.Select
    Application.CutCopyMode = False
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5, 6), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
 
     'ajout
'     Range("A1").Select
'     Selection.Font.Bold = True
'     Selection.Font.ColorIndex = 3
'     Selection.Font.Underline = xlUnderlineStyleSingle
     With Range("A1").Font
        .Bold = True
        .ColorIndex = 3
        .Underline = xlUnderlineStyleSingle
     End With
 
     Rows("1:1").RowHeight = 26.25
 
'     Range("A2:F2").Select
'     Selection.Font.Bold = True
'     Selection.Font.ColorIndex = 11
 
     With Range("A2:F2").Font
        .Bold = True
        .ColorIndex = 11
     End With
    'fin ajout
 
    '**************Ajout de code pour placer une ligne vide
Dim max As Long
Dim indice As Long
Dim flag_total As Boolean
 
flag_total = False
indice = 2
 
max = ActiveSheet.Range("A1000").End(xlUp).Row 'pas besoin de plus que 1000
Do While indice < max + 1
 
 Select Case True
        Case flag_total
            'fin ajout
            Rows(indice).Insert Shift:=xlDown
            flag_total = False
            max = max + 1
        Case UCase(Left(Range("A" & indice), 5)) = "TOTAL"
            flag_total = True
            'Nouvel ajout pour le caractère gras
            Rows(indice).Font.Bold = True
        Case Else
 End Select
indice = indice + 1
Loop
 
 
'****************fin de code
 
    'Cette ligne sert à cliquer sur le petit 2 dans le carré à gauche pour le sommaire
    ActiveSheet.Outline.ShowLevels RowLevels:=2
   ' sert à mettre les colonnes de la bonne largeur
    Columns("A:A").ColumnWidth = 33.29
    Columns("B:B").ColumnWidth = 13#
    Columns("C:C").ColumnWidth = 17#
    Columns("D:D").ColumnWidth = 7.86
    Columns("E:E").ColumnWidth = 17#
    Columns("F:F").ColumnWidth = 8.43
      Columns("E:E").Select
    Range("E11").Activate
    Selection.NumberFormat = "0.00"
    Columns("F:F").Select
    Range("F11").Activate
    Selection.NumberFormat = "0.00"
 
       Sheets("Feuil2").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Feuil3").Select
    ActiveWindow.SelectedSheets.Delete
 
    '*************AJOUT POUR METTRE LA FEUILLE EN PAYSAGE
    With ActiveSheet.PageSetup
 
        .Orientation = xlLandscape
 
    End With
    '******************FIN PAYSAGE
    Range("G1").Select

Un petit exemple serait bien venu

**Prekestolen** · 16/04/2009, 14h56

Voici un fichier sur lequel executer le code

**Prekestolen** · 16/04/2009, 15h11

Pour répondre au fait que le code est lourd, c'est que comme je fais peu de programmation. Lorsque je dois faire une macro, j'utilise la fonction d'Excel Outils-Macro-Nouvelle Macro. Je fais l'exercise pas à pas et une grosse partie du code se fait automatiquement. Je bricole un peu le code pour que l'exécution se fasse comme il faut et c'est tout. Je fais de la programmation de base, rien d'élaboré. Moi, mon travail se fait sur Crystal Report et une fois mon rapport fait, je dois parfois le travailler en Excel (il y a une fonction dans Crystal pour exporter en Excel) comme c'est le cas présent. C'est pour cette raison que je viens dans le forum Excel et non dans celui de Crystal, car mon problème est avec Excel et non Crystal.

**Prekestolen** · 16/04/2009, 22h19

Rebonjour à tous

Bonne nouvelle, en fouillant avec la fonction Recherche, j'ai trouvé du code qui m'a permis de faire ce que je veux. Merci à celui qui a écrit

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Dim R As Long
Application.ScreenUpdating = False
 
For R = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
    If Application.WorksheetFunction.CountA(Rows(R)) = 0 Then Rows(R).Delete
Next R
 
Application.ScreenUpdating = True

Ca a marché du premier coup. Mais il y a un petit quelque chose qui m'embête. Est-ce que ce bout de code fait en sorte que la fonction se rende jusqu'à la fin de la feuille Excel (65535 lignes)? Si oui comment faire pour qu'elle arrête après le dernier "Total".

Merci

**JPierreM** · 16/04/2009, 22h39

Je suppose que le dernier Total se trouve dans la colonne A et qu'après les lignes sont vides

Donc pour sélectionner la cellule juste en dessous du dernier Total

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
sub sc
Range("A65536").End(xlUp).Offset(1, 0).Select
end sub

Par contre le dernier code dont tu parles n'a plus rien à voir avec le sujet du départ où il était question de sous-totaux.
Il est parfois bien difficile de se comprendre.

Insérer un total sous les données [XL-2002]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager