Addition et pourcentage

1 pièce(s) jointe(s)

Bonjour à tous

Voici mon code
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Selection.Merge Range("J2").Select Selection.Copy Range("A1:I1").Select ActiveSheet.Paste Range("A1:F1000").Select Range("I1000").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(5, 6, 7, 8), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True
et il y a une image de mon tableau.

Comment faire pour récupérer les cellules qui sont la somme des additions.
Prendre la cellule prime (en rouge) et la divisé par la cellule comm (en bleu) pour obtenir la celllule jaune. Il y a des rangées avant celles-ci mais je ne les ai pas mis pour ne pas alourdir le message. Si vous avez une lumière pour m'éclairer, vous pouvez l'allumer, je vous en serai grandement reconnaissant. Merci d'avance à toute la communauté.

je ne sais pas... mais ton code ne pointe vraiment sur rien qui est dans ton classeur que tu as en fichier attaché....

mais pour ta case jaune tout simplement :

Code:

=B9/A9

Ensuite clique droit sur ta cellule jaune (C9) et change le format de la cellule en Pourcentage.

Mais un peu d'Explication serait apprécié pour ton code ??? pourquoi tu selectionne la case J2 pour la recopier dans le Range A1:I1 ? et ensuite selectionner I1000 et y coller absolument rien ?

ouin... j'aurais du être plus clair (j'ai écrit le message en vitesse avant de partir espérant pouvoir obtenir une piste car je ne suis pas vraiment programmeur ). Je ne peux pas faire ce que tu dis car le nombre d'enregistrement n'est pas défini. Parfois le total va tomber à la ligne 11, une autre fois ce sera à la ligne 15 une autre fois ce sera la ligne 6, tu coomprends. Pour ce qui est de la cellule J2, c'est par rapport à une autre parti du code. Je vais essayer d'etre plus clair.

Dans ma macro, je fait exécuter la commande Donnée sous-totaux. Je demande des sous-totaux pour les colonnes G et H. Ensuite il faut que le sous-totaux H se diveise par le sous-totaux G pour obtenir ce que l'on veux.
Voici mon code au complet (attention, je répète je ne suis pas un programmeur donc je fais mes macro avec l'enregistreur de macro et je transforme ensuite un peu le code. Présentement cela fonctionne parfaitement même si cela peuc vous sembler bizarre.

Code:

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
116
117
118
119
120
121
122
123
124
125
126
 Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1:I1").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("J2").Select
    Selection.Copy
    Range("A1:I1").Select
    ActiveSheet.Paste
    Range("A1:F1000").Select
    Range("I1000").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(5, 6, 7, 8), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'**********************nouveau code
'Supprime les lignes où il n'y a rien
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
 
'***********************fin nouveau code
     'ajout
     Range("A1").Select
     Selection.Font.Bold = True
     Selection.Font.ColorIndex = 3
     Selection.Font.Underline = xlUnderlineStyleSingle
     Rows("1:1").RowHeight = 26.25
     Range("A2:I2").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
    Columns("B:B").ColumnWidth = 13
    Columns("C:C").ColumnWidth = 30
    Columns("D:D").ColumnWidth = 15
    Columns("E:E").ColumnWidth = 10
    Columns("F:F").ColumnWidth = 18
    Columns("G:G").ColumnWidth = 12
 
    'Pour mettre les colonnes dans le bon format
        Columns("E:E").Select
        Selection.NumberFormat = "0"
        Columns("F:F").Select
        Selection.NumberFormat = "0.00$"
        Columns("G:G").Select
        Selection.NumberFormat = "0.00$"
         Columns("H:H").Select
        Selection.NumberFormat = "0.00$"
        Columns("I:I").Select
        Selection.NumberFormat = "0.00%"
 
    'suppression des feuille vide dans le classeur
       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
 
'pour enlever la vue des pied de pages
      ActiveSheet.DisplayAutomaticPageBreaks = False
 
'pour se mettre à la fin des données
    Range("A65536").End(xlUp).Offset(1, 0).Select
 
End Sub

Merci