Insertion d'un sous-total
bonjour a vous tous
dans ce fichier https://www.cjoint.com/c/CKbi661bd8M j’essaie d'intégrer le calcul du sous-total qu'un code trouvé sur le net le fait mais que j'ai essayer d'adapter sans succès dont voici le code
Private Sub CommandButton4_Click()
Dim LIGNE As Integer
LIGNE = Me.Label13.Caption
With ActiveSheet
.Cells(LIGNE, 3).MergeCells = False '
'.Range(.Cells(LIGNE, 7), .Cells(LIGNE, 8)).MergeCells = True
.Cells(LIGNE, 8).Select
ActiveCell.Formula = "=SUM(" & .Range(.Cells(CDbl(Me.Label13.Caption), 12), .Cells(LIGNE, 12)).Address & ")"
.Cells(LIGNE, 7).Value = "Sous-Total : "
.Cells(LIGNE, 7).Font.Bold = True
.Cells(LIGNE, 7).HorizontalAlignment = xlRight
.Cells(LIGNE, 11).Value = "" ' Pour effacer le 0,00
.Cells(LIGNE, 12).Value = "" ' Pour effacer le 0,00
.Cells(LIGNE, 13).Value = "" ' Pour effacer le 1
LIGNE = LIGNE + 1
Me.Label13.Caption = LIGNE
Me.Label14.Caption = LIGNE
End With
End Subje pense que c'est du au chargement des labels qu'une partie est non fonctionnel
le fichier joint ne correspond pas tout a fait au classeur utiliser sauf au niveau de l'organisation des colonnes et les lignes s'ajoutent l'une après l'autre
Pascal
Bonjour,
le fichier que tu nous as envoyé ne contient pas le formulaire avec le label13.
peux-tu adapter le code, l'exécuter et vérifier si ce qui est affiché via le message box te semble correct.
formulesomme = "=SUM(" & .Range(.Cells(CDbl(Me.Label13.Caption), 12), .Cells(LIGNE, 12)).Address & ")"
MsgBox formulesomme
ActiveCell.Formula = formulesommebonsoir h2so4
merci de ta réponse et le message qui s'affiche est égal à "sum($L$19) soit la somme de L19
le fichier joint a un usf matériel démuni de tous ses textbox et confrère mais est équipé d'un usf "liste du matériel" avec 2 boutons et 2 labels 13 et 14 cela aurai pu être 1 et 2 mais c'est leur numéros sur le classeur
je te prépare un autre fichier
Pascal
grisan29 a écrit :bonsoir h2so4
merci de ta réponse et le message qui s'affiche est égal à "sum($L$19) soit la somme de L19
et est-ce le résultat auquel tu t'attendais ? est-ce correct ? moi je m'attendais à voir quelque chose du style
=SUM($A$1:$L$19) le $A$1 dépendant du contenu de ton label13.
re
non ce n'est pas ce que j'attendais ,mais le calcul de la somme des montants ht je te joint un nouveau classeur avec ce que j'attends
en fait il faudrait que je puisse inscrire le sous total de chaque partie d'un devis comme le montre cet exemple
https://www.cjoint.com/c/CKbu6n82RyV
Pascal
Bonsoir,
pour moi l'erreur se situe au niveau de cette ligne. en mettant cette instruction tu feras toujours la somme d'une seule ligne puisque ligne et me.label13.caption auront toujours la même valeur au moment où ils sont utilisés pour créer la formule pour le sous-total.
Private Sub CommandButton3_Click()
Dim LIGNE As Integer
LIGNE = Me.Label13.Caption
With ActiveSheetmais il manque des bouts de code pour pouvoir t'aider, désolé
je veux bien regrder en MP si tu le souhaites.
bonsoir h2so4
en fait je viens de rechercher avec mal où j'avais trouvé ce bout de code mais le reste du programme est non accessible mais parle de modules de classe
Pascal
Bonjour,
une macro sous-total sur base de ta feuille facture et ce que j'en ai compris.
Sub soustotal()
lf = 19
fl = 0
Set Ws = ActiveSheet
Application.EnableEvents = False
calculationparam = Application.Calculation
Application.Calculation = xlCalculationManual
While Left(Ws.Cells(lf, 3), 5) <> "Arrêt"
If fl = 0 And Ws.Cells(lf, 3) <> "" Then
'ligne rubrique trouvée
fl = lf
ElseIf fl <> 0 And (Ws.Cells(lf, 4) = "" Or Ws.Cells(lf, 3) <> "") Then
'ligne blanche ou ligne nouvelle rubrique trouvée après le détail d'une rubrique
If Ws.Cells(lf, 7) <> "sous-total:" Then
'il n'y a pas encore de ligne sous-total, on insère une nouvelle ligne
Ws.Rows(lf).Insert Shift:=xlDown
End If
Ws.Cells(lf, 7) = "sous total:"
Ws.Cells(lf, 7).NumberFormat = "0.00€"
fs = "=sum(" & Ws.Cells(fl, 9).Address & ":" & Ws.Cells(lf - 1, 9).Address & ")"
Ws.Cells(lf, 8).Formula = fs
fl = 0
End If
lf = lf + 1
Wend
Application.EnableEvents = True
calculationparam = Application.Calculation
Application.Calculation = calculationparam
End Subbonjour h2so4
Merci pour ce code qui fonctionne très bien mais le sous total ne devrai pas être mis a toutes les sections en même temps mais l'un après l'autre
Pascal
rebonjour,
code adapté pour faire le sous-total de la rubrique selectionnée. la rubrique est sélectionnée en cliquant sur la cellule qui contient la rubrique. je ne sais pas comment cette manière de faire va s'intégrer dans le reste de ton application. je te laisserai faire les adaptations nécessaires.
Sub soustotal()
Set Ws = ActiveSheet
lf = ActiveCell.Row
If ActiveCell.Column <> 3 Or ActiveCell = "" Then
MsgBox "vous devez selectionner la rubrique pour laquelle vous voulez un sous-total"
Exit Sub
End If
fl = 0
Application.EnableEvents = False
calculationparam = Application.Calculation
Application.Calculation = xlCalculationManual
soustotalencours = True
While soustotalencours
If fl = 0 And Ws.Cells(lf, 3) <> "" Then
'ligne rubrique trouvée
fl = lf
ElseIf fl <> 0 And (Ws.Cells(lf, 4) = "" Or Ws.Cells(lf, 3) <> "") Then
'ligne blanche ou ligne nouvelle rubrique trouvée après le détail d'une rubrique
If Ws.Cells(lf, 7) <> "sous-total:" Then
'il n'y a pas encore de ligne sous-total, on insère une nouvelle ligne
Ws.Rows(lf).Insert Shift:=xlDown
End If
Ws.Cells(lf, 7) = "sous total:"
Ws.Cells(lf, 7).NumberFormat = "0.00€"
fs = "=sum(" & Ws.Cells(fl, 9).Address & ":" & Ws.Cells(lf - 1, 9).Address & ")"
Ws.Cells(lf, 8).Formula = fs
soustotalencours = False
fl = 0
End If
lf = lf + 1
Wend
Application.EnableEvents = True
Application.Calculation = calculationparam
End Subbonjour h2so4
merci beaucoup de ton aide
c'est parfait ,je clos ce post grâce a ton aide parfaite
Pascal
un petit plus si c'est possible
merci pour "
MsgBox "vous devez selectionner la rubrique pour laquelle vous voulez un sous-total"
justement quand je sélectionne une rubrique est ce que
ws.Cells(lf, 7) = "Sous Total:"peut prendre en plus le nom de la rubrique sélectionnée
après je clos
Pascal
bonsoir
code adapté
Sub soustotal()
Set Ws = ActiveSheet
'lf numéro de dernière ligne pour la formule sous-total
lf = ActiveCell.Row
' on vérifie que la cellule sélectionnée est bien un entête de rubrique
If ActiveCell.Column <> 3 Or ActiveCell = "" Then
MsgBox "vous devez selectionner la rubrique pour laquelle vous voulez un sous-total"
Exit Sub
End If
' fl numéro de première ligne pour la formule sous-total
fl = 0
' on empêche les events
Application.EnableEvents = False
' on mémorise le paramétrage pour le calcul
calculationparam = Application.Calculation
' on met le paramétrage du calcul en manuel
Application.Calculation = xlCalculationManual
' soustotalencours variable de controle de la boucle
soustotalencours = True
' tant qu'on a pas terminé l'exercice de sous-total
While soustotalencours
If fl = 0 And Ws.Cells(lf, 3) <> "" Then
'ligne rubrique trouvée
fl = lf
ElseIf fl <> 0 And (Ws.Cells(lf, 4) = "" Or Ws.Cells(lf, 3) <> "") Then
'ligne blanche ou ligne nouvelle rubrique trouvée après le détail d'une rubrique
If Left(Ws.Cells(lf, 7), 4) <> "sous" Then
'il n'y a pas encore de ligne sous-total, on insère une nouvelle ligne
Ws.Rows(lf).Insert Shift:=xlDown
End If
' on inscrit sous-total, suivi de la rubrique, suivi de ":"
Ws.Cells(lf, 7) = "sous total " & Ws.Cells(fl, 3) & " : "
' on fait le cadrage à droite
Ws.Cells(lf, 7).HorizontalAlignment = xlRight
' on adapte le format pour la somme
Ws.Cells(lf, 7).NumberFormat = "0.00€"
' on insère la formule =sum( fl,lf-1)
fs = "=sum(" & Ws.Cells(fl, 9).Address & ":" & Ws.Cells(lf - 1, 9).Address & ")"
Ws.Cells(lf, 8).Formula = fs
soustotalencours = False
fl = 0
End If
lf = lf + 1
Wend
Application.EnableEvents = True
Application.Calculation = calculationparam
End Subbonsoir h2so4
merci
Pascal
il faudrai que
puisse etre sur 2 cellules maintenant par exemple la 6 et 7 car il faut plus d'espacews.Cells(lf, 7) = "sous total " & ws.Cells(fl, 3) & " : "
Pascal
bonsoir,
Normalement, l'instruuction suivante, que j'ai mise dans le code devrait permettre d'éviter ce problème espace.
Ws.Cells(lf, 7).HorizontalAlignment = xlRightbonsoir h2so4
la cellule est trop petite et
se trouve en retour à la ligne dans la cellule"sous total : salle de bains"
Pascal
et ainsi ?
Sub soustotal()
Set Ws = ActiveSheet
'lf numéro de dernière ligne pour la formule sous-total
lf = ActiveCell.Row
' on vérifie que la cellule sélectionnée est bien un entête de rubrique
If ActiveCell.Column <> 3 Or ActiveCell = "" Then
MsgBox "vous devez selectionner la rubrique pour laquelle vous voulez un sous-total"
Exit Sub
End If
' fl numéro de première ligne pour la formule sous-total
fl = 0
' on empêche les events
Application.EnableEvents = False
' on mémorise le paramétrage pour le calcul
calculationparam = Application.Calculation
' on met le paramétrage du calcul en manuel
Application.Calculation = xlCalculationManual
' soustotalencours variable de controle de la boucle
soustotalencours = True
' tant qu'on a pas terminé l'exercice de sous-total
While soustotalencours
If fl = 0 And Ws.Cells(lf, 3) <> "" Then
'ligne rubrique trouvée
fl = lf
ElseIf fl <> 0 And (Ws.Cells(lf, 4) = "" Or Ws.Cells(lf, 3) <> "") Then
'ligne blanche ou ligne nouvelle rubrique trouvée après le détail d'une rubrique
If Left(Ws.Cells(lf, 7), 4) <> "sous" Then
'il n'y a pas encore de ligne sous-total, on insère une nouvelle ligne
Ws.Rows(lf).Insert Shift:=xlDown
End If
' on inscrit sous-total, suivi de la rubrique, suivi de ":"
Ws.Cells(lf, 7) = "sous total " & Ws.Cells(fl, 3) & " : "
' on fait le cadrage à droite
Ws.Cells(lf, 7).HorizontalAlignment = xlRight
Ws.Cells(lf, 7).WrapText = False
' on adapte le format pour la somme
Ws.Cells(lf, 8).NumberFormat = "0.00€"
' on insère la formule =sum( fl,lf-1)
fs = "=sum(" & Ws.Cells(fl, 9).Address & ":" & Ws.Cells(lf - 1, 9).Address & ")"
Ws.Cells(lf, 8).Formula = fs
soustotalencours = False
fl = 0
End If
lf = lf + 1
Wend
Application.EnableEvents = True
Application.Calculation = calculationparam
End Subbonsoir H2so4
Parfait le wraptext=false
merci pour ce dimanche où il n'a pas arrêter de pleuvoir en Bretagne
Pascal
bonjour H2so4 et le forum
j'ai un petit souci car je n'avais pas tout préciser dans ma demande initiale
quand je mets une tranche dans ma feuille puis des lignes d'article le code du sous total fonctionne a merveille, mais lorsque la tranche est suivie d'un commentaire le sous total s'inscrit entre les 2 (pas cool) je joint un exemple pour une meilleure compréhension
https://www.cjoint.com/c/CKyjmma9vJr
par ailleurs est ce que
ws.Cells(lf, 7) = "sous total : " & ws.Cells(fl, 3) & " : "peu s'écrire comme les articles en fusionnant les cellules D à G et laisser H pour le total car les boutons qui me permette de remonter une ligne où la descendre zappe la ligne sous total dont voici le code de remonter
Private Sub Remonter_Ligne()
Dim T(), NoLigne As Long, S As Double, H As Double
Dim DerLig As Long, Ok As Boolean, ActLigne As Long
'Feuil1 est le nom de la propriété de l'objet "Feuille" visible
'dans la fenêtre de l'éditeur de code et non le nom de l'onglet
'de la feuille.
'With Feuil1
With Worksheets("facture")
'Trouve la dernière ligne occupée dans les colonnes c:h
DerLig = .Range("C:H").Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'Si ton tableau était vide, la dernière ligne serait
'la première ligne de ton tableau.
If DerLig < 19 Then DerLig = 19
End With
'Si l'usager a sélectionné une cellule dans la plage C19:Cx
If Not Intersect(ActiveCell, Range("C19:H" & DerLig)) Is Nothing Then
'Une variable pour le numéro de ligne
NoLigne = ActiveCell.Row
'Si la ligne sélectionnées est en caractère grand et fusionnée
If Range("C" & NoLigne).MergeCells = True And Range("C" & NoLigne).Font.Bold = True Then
'On remonte d'une ligne
ActiveCell.offset(-1).Select
'On met fin à l'opération
Exit Sub
End If
'si la ligne active est 19, fin des opérations
'car on ne peut pas remonter plus haut
If ActiveCell.Row = 19 Then Exit Sub
'une petite boucle afin de trouver la ligne aus-dessus de la ligne
'Active qui ne soit pas fusionnée et en caractère gras.
Do
NoLigne = NoLigne - 1
If Range("C" & NoLigne).MergeCells <> True Then 'And _Range("C" & NoLigne).Font.Bold <> True Then
'Si le critère est respecter, sortie de la boucle
Ok = True
Exit Do
End If
Loop Until NoLigne = 19
'Une deuxième variable pour le numéro de la ligne de la cellule active.
ActLigne = ActiveCell.Row
'Au sortir de la boucle, si tout est Ok
If Ok = True Then
'met dans une variable tableau, le contenu de la ligne
T = Rows(NoLigne).Cells.Value
'met dans S la hauteur de la ligne active
S = Rows(ActLigne).Height
'met en H la hauteur de la ligne où sera copiée les données
H = Rows(NoLigne).Height
'Copie de la ligne active vers la ligne au-dessus
Rows(NoLigne).Value = Rows(ActLigne).Value
'Mise à jour des formules ligne NoLigne
Range("L" & NoLigne).Formula = "=$I" & NoLigne & "*$K" & NoLigne
'partie en dessous bon mais pas encore fonctionnelle (je cherche pourquoi)
Range("o" & NoLigne).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-6]*RC[-4]*0.07,"""")"
Range("P" & NoLigne).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-7]*RC[-5]*0.196,"""")"
'Copie des valeurs de T dans la ligne active
Rows(ActLigne) = T
'Nouvelle hauteur de la ligne de la ligne active s'il y a lieu
Rows(ActLigne).RowHeight = H
'Nouvelle hauteur de la ligne de la ligne au-dessus s'il y a lieu.
Rows(NoLigne).RowHeight = S
'Mise à jour des formules ligne ActLigne
Range("L" & ActLigne).Formula = "=$I" & ActLigne & "*$K" & ActLigne
Range("o" & ActLigne).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-6]*RC[-4]*0.07,"""")"
Range("P" & ActLigne).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=1,RC[-7]*RC[-5]*0.196,"""")"
'sélection de la ligne où ont été copiées les données
Rows(NoLigne).Cells(1, 4).Select
End If
End If
End Suble code descendre est identique a peu de chose près
et lorsque le sous total est écrit en bas du devis comment peut 'on faire pour qu'il ne se trouve pas tout seul après la bordure, mais avant la bordure
Pascal
bonsoir a vous tous
n'ayant pas eu de réponse je clos le post car j'ai fait un compromis
Pascal