XL 2016 macro tarif degressif

[youpi457032]

Bonjour,
Je cherche une macro pour inscrire dans une textbox unique le produit d'une somme. Je m'explique
J'ai des liste Box (8) qui contiennent des intitulés de cours. Chaque listBox a son intitulé variable.
Si j' ai un cours le tarif est de 200
Si je m'inscris dans deux cours le tarif est de 380
Si je m'inscris dans 3 cours et plus le tarif est de 540. a partir de trois cours et plus le tarif ne change plus.
En clair in faut compter le nombre de liste box non vide et faire la somme en fonction du nombre de cours (1, 2 ou trois et plus).
C'est la première étape.

Je voudrais complexifier. J'ai deux catégories de cours : des cours hebdomadaires, et des cours mensuels. Seuls les cours hebdomadaires sont concernés par cette dégressivité. A coté, les cours mensuels ne sont pas dégressifs.
Je voudrais que la macro fasse le distinguo entre ces deux types de cours, et additionne le prix des cours hebdomadaires (avec la règle du tarif dégressif) et le prix des cours mensuels (cumulables et non dégressifs). Le résultat doit s'afficher dans une unique textbox.

Je peux dans une feuille nommée "Critère" lister dans deux colonnes différentes les cours mensuels et les cours hebdomadaires. J'ai cette feuille, elle me sert pour d'autres macro....
Quelqu'un peut-il m'aider ?

 

[Paf]

Bonjour,

les listbox sont sur userform ou feuille ?
chaque listbox contient, au plus, 1 cours ? ou bien y en a t il plusieurs et il ne faut compter que ceux selectionnés ?

Sans classeur support de réflexion , difficile de proposer quelque chose...

A+

 

[youpi457032]

Bonjour,
Merci de prêter attention à mon fil ! c'est très gentil.
Les listbox sont dans un Userform
J'ai 8 listbox qui reprennent les cours qui sont référencés dans une colonne à part sur feuille Critères
Ces listesbox permettent via l'userform de renseigner une feuille facturation.
j'ai trois champ de facturation :
un champ "montant Dû", un champ "montant perçu", et un champ "à percevoir"
J'ai solutionné ma macro pour les deux champs "perçu" et à percevoir.
Je voudrais remplir le champ "montant dû" via une macro automatique qui me calcul le prix à devoir en fonction de plusieurs critères.
le prix de la licence (prix fixe), le prix des frais d'inscription (prix fixe) et le prix des cours qui lui varie selon plusieurs critères
PREMIER critère : j'ai deux catégories de cours : des cours hebdomadaires et des cours mensuels (on doit pouvoir les référencer en les distinguant sur deux listes différentes en colonne dans ma feuille critère, là dessus pas de souci)
Ensuite :
s'il s'agit des cours mensuels, chaque cours est au même tarif et est invariable ( ex : un cours = 200 €, deux cours = 400 €....etc)
s'il s'agit des cours hebdomadaires on applique une dégressivité comme suit :
un cours pris : tarif normal : ex 200 €
deux cours pris : 360 €
trois cours pris et au delà …. : 520 €

la macro doit être capable en fonction des cours de faire d'une part la différence entre les cours mensuels et les cours hebdomadaires (donc de les repérer dans la base, pour chaque élève : donc chaque ligne non vide) et ensuite d'appliquer les tarifs ( X cours mensuels….= simple multiplication), avec en plus le prix des cours mensuels en fonction du tarif UN, DEUX, ou TROIS COURS et plus.
Merci ….
Je joins mon fichier complet ( vierge de toute donnée confidentielle). Le USERFORM concerné est règlement_facturation. La feuille de référence est la feuille Facturation.
dans la feuille critère j'ai listé les cours pars catégorie ( colonnes G à K ) avec la grille tarifaire ( toutes ces listes, cours et tarifs peuvent evoluer)

 

[Paf]

un essai en rajoutant une sub dans le module de l'userform règlement_facturation :

Sub PrixCours()
Dim i As Integer, M As Boolean, NM As Integer, NH As Integer, PH, PM As Integer, j As Integer

PM = 200 'prix cours mensuel
PH = Array(0, 200, 360, 520) ' tableau prix hebdo

With Worksheets("Critères")
For i = 6 To 13
    M = False
    If Controls("T" & i).ListIndex <> -1 Then
        For j = 3 To .Range("G" & Rows.Count).End(xlUp).Row
            If .Range("G" & j) = Controls("T" & i) Then
                M = True
                Exit For
            End If
        Next
        If M Then 'si cours mensuel
            NM = NM + 1
        Else 'cours hebdo
            NH = NH + 1
        End If
    End If
Next
End With
If NH > 3 Then NH = 3
Label70.Caption = PH(NH)
Label72.Caption = NM * PM
End Sub

nécessite de rajouter un appel à cette sub:
-en fin de Private Sub T1_Click() pour afficher les prix dès le choix d'un nom
-pour les combobox 6 à 13 (Private Sub T6_Change(), Private Sub T7_Change()...) pour mettre à jour les prix si rajout ou suppression de cours

les prix des cours hebdo ou mensuels s'affichent dans les Label70 et Label72 (à rajouter dans l'USF),
mais on pourrait affecter ces montants à des variables et les utiliser pour un calcul du montant global.

A+

 

[youpi457032]

Bonjour, Merci.
Concrètement comment j'insère ma macro pour qu'elle fonctionne ?
j'ai rajouter le sub tout à la fin mais rien ne se passe ?
je câle….. peux tu me l'installer dans mon code de l'USERFORM dans le fichier joint que je comprenne ?

 

[Paf]

Comme dit plus haut ,
copier la sub dans la feuille de code de l'usf règlement_facturation
Rajouter l'appel à cette sub (PrixCours) en fin de Private Sub T1_Click() et dans Private Sub Tx_Change() pour les combo T6 à T13.

 

[youpi457032]

un essai en rajoutant une sub dans le module de l'userform règlement_facturation :

Sub PrixCours()
Dim i As Integer, M As Boolean, NM As Integer, NH As Integer, PH, PM As Integer, j As Integer

PM = 200 'prix cours mensuel
PH = Array(0, 200, 360, 520) ' tableau prix hebdo

With Worksheets("Critères")
For i = 6 To 13
    M = False
    If Controls("T" & i).ListIndex <> -1 Then
        For j = 3 To .Range("G" & Rows.Count).End(xlUp).Row
            If .Range("G" & j) = Controls("T" & i) Then
                M = True
                Exit For
            End If
        Next
        If M Then 'si cours mensuel
            NM = NM + 1
        Else 'cours hebdo
            NH = NH + 1
        End If
    End If
Next
End With
If NH > 3 Then NH = 3
Label70.Caption = PH(NH)
Label72.Caption = NM * PM
End Sub

nécessite de rajouter un appel à cette sub:
-en fin de Private Sub T1_Click() pour afficher les prix dès le choix d'un nom
-pour les combobox 6 à 13 (Private Sub T6_Change(), Private Sub T7_Change()...) pour mettre à jour les prix si rajout ou suppression de cours

les prix des cours hebdo ou mensuels s'affichent dans les Label70 et Label72 (à rajouter dans l'USF),
mais on pourrait affecter ces montants à des variables et les utiliser pour un calcul du montant global.

A+

bonjour,
J'ai procédé comme suit :
- J'ai copié ta macro
- J'ai installé les label 70 et 72
- J'ai en fin de Private Sub T1_Click()

rajouter la commande suivante comme suit :
Private Sub T1_Click()
Dim Lig&, i&
If T1.ListIndex <> -1 Then
Lig = T1.ListIndex + 2
For i = 1 To 30
Controls("T" & i) = Feuil5.Cells(Lig, i).Value
Next i
End If
​

Call PrixCours​

End Sub
- puis j'ai fait de même avec (

Private Sub T6_Change() qui est devenu​

Private Sub T6_Change()​

Call PrixCours​

End Sub
- Même chose

avec (

Private Sub T6_Change() qui est devenu​

Private Sub T7_Change()
Call PrixCours
End Sub​

voila pour les modifications opérées si j'ai bien suivi et correctement ce que tu m'as dit de faire

A l'execution voilà ce que ca me renvoie en pièce jointe….

Où est-ce que je me plante ???????
merci !
[/CODE]

​

 

[youpi457032]

je complète ma réponse en mettant la macro complète

[/CODE]​

'Macro Faite par DESVIGNE Christophe le 30/05/2019
Option Explicit
Private Sub Bt1_Click()
Dim Lig&, i&
If T1 = "" Or T2 = "" Then MsgBox "Vous devez au minimum remplir le nom et le pr?nom pour pouvoir enregistrer un ?l?ve!!", vbCritical, "Manque de donn?e": Exit Sub
With Feuil5
If T1.ListIndex <> -1 Then
Lig = T1.ListIndex + 2
For i = 1 To 30
If i = 10 Or i = 11 Or i = 15 Or i = 18 Or i = 21 Then .Cells(Lig, i) = Controls("T" & i): GoTo 1
If IsNumeric(Controls("T" & i)) Then
.Cells(Lig, i) = CDbl(Controls("T" & i))
Else
.Cells(Lig, i) = Controls("T" & i)
End If
1 Next i
Else
Lig = .Range("A" & Rows.Count).End(3).Row + 1
For i = 1 To 30
If i = 10 Or i = 11 Or i = 15 Or i = 18 Or i = 21 Then .Cells(Lig, i) = Controls("T" & i): GoTo 2
If IsNumeric(Controls("T" & i)) Then
.Cells(Lig, i) = CDbl(Controls("T" & i))
Else
.Cells(Lig, i) = Controls("T" & i)
End If
2 Next i
End If
End With
Bt2_Click
End Sub
Private Sub Bt2_Click()
Unload Me
r?glement_facturation.Show 0
End Sub
Private Sub Bt3_Click()
Dim rep, rep1
If T1.ListIndex <> -1 Then
rep = MsgBox("Attention vous allez Supprimer l'?l?ve actuellement s?lectionn?, ?tes vous sur de vouloir Supprimer l'?l?ve??", vbCritical + vbYesNo, "Suppression d'un ?l?ve")
If rep = vbNo Then Exit Sub
rep1 = MsgBox("Attention vous allez Supprimer un ?l?ve??, confirmer vous la suppression, action irr?versible??", vbCritical + vbYesNo, "Confirmation de Suppression d'un ?l?ve")
If rep1 = vbNo Then Exit Sub
Feuil1.Rows(T1.ListIndex + 2).Delete shift:=xlUp
Bt2_Click
End If
End Sub
Private Sub Bt4_Click()
Unload Me
End Sub
Private Sub edition_facture_Click()
On Error GoTo OuvertureFichierErreur
Dim MonApplication As Object
Dim MonFichier As String

Set MonApplication = CreateObject("Shell.Application")

MonFichier = "C:\Users\Christophe DESVIGNE\Desktop\Nouveau dossier\attestation de paiement.docx"

MonApplication.Open (MonFichier)

Set MonApplication = Nothing
Exit Sub
OuvertureFichierErreur:

Set MonApplication = Nothing

MsgBox "Erreur lors de l'ouverture de fichier..."
End Sub

Private Sub T1_Click()
Dim Lig&, i&
If T1.ListIndex <> -1 Then
Lig = T1.ListIndex + 2
For i = 1 To 30
Controls("T" & i) = Feuil5.Cells(Lig, i).Value
Next i
End If
Call PrixCours

End Sub
Private Sub T28_Change()
End Sub
Private Sub T29_Change()
T29.Value = Val(T21.Value) + Val(T22.Value) + Val(T23.Value) + Val(T24.Value) + Val(T25.Value) + Val(T26.Value) + Val(T27.Value)
End Sub
Private Sub T30_Change()
T30.Value = Val(T28.Value) - Val(T29.Value)
End Sub
Private Sub T6_Change()
Call PrixCours
End Sub
Private Sub T7_Change()
Call PrixCours
End Sub
Private Sub UserForm_Initialize()
Dim aa, fin&, i&
With Feuil5
fin = .Range("A" & Rows.Count).End(3).Row
If fin < 2 Then Exit Sub
aa = .Range("A2:AC" & fin)
End With
T1.ColumnCount = 2
T1.List = aa
T4.List = Feuil2.Range("C2:C" & Feuil2.Range("C" & Rows.Count).End(3).Row).Value
For i = 6 To 13
Controls("T" & i).List = Feuil2.Range("A2:A" & Feuil2.Range("A" & Rows.Count).End(3).Row).Value
Next i
For i = 14 To 20
Controls("T" & i).List = Feuil2.Range("E2:E" & Feuil2.Range("E" & Rows.Count).End(3).Row).Value
Next i
End Sub
Sub PrixCours()
Dim i As Integer, M As Boolean, NM As Integer, NH As Integer, PH, PM As Integer, j As Integer
PM = 200 'prix cours mensuel
PH = Array(0, 200, 360, 520) ' tableau prix hebdo
With Worksheets("Crit?res")
For i = 6 To 13
M = False
If Controls("T" & i).ListIndex <> -1 Then
For j = 3 To .Range("G" & Rows.Count).End(xlUp).Row
If .Range("G" & j) = Controls("T" & i) Then
M = True
Exit For
End If
Next
If M Then 'si cours mensuel
NM = NM + 1
Else 'cours hebdo
NH = NH + 1
End If
End If
Next
End With
If NH > 3 Then NH = 3
Label70.Caption = PH(NH)
Label72.Caption = NM * PM
End Sub

[/CODE]

A l'execution le débogueur bloque sur T1.ColumnCount = 2, un peu plus haut en jaune . Jusqu'à présent ca lui posait pa de problème .
Peux tu m'aider a comprendre ce qui se passe ?
Merci​

 

[youpi457032]

un essai en rajoutant une sub dans le module de l'userform règlement_facturation :

Sub PrixCours()
Dim i As Integer, M As Boolean, NM As Integer, NH As Integer, PH, PM As Integer, j As Integer

PM = 200 'prix cours mensuel
PH = Array(0, 200, 360, 520) ' tableau prix hebdo

With Worksheets("Critères")
For i = 6 To 13
    M = False
    If Controls("T" & i).ListIndex <> -1 Then
        For j = 3 To .Range("G" & Rows.Count).End(xlUp).Row
            If .Range("G" & j) = Controls("T" & i) Then
                M = True
                Exit For
            End If
        Next
        If M Then 'si cours mensuel
            NM = NM + 1
        Else 'cours hebdo
            NH = NH + 1
        End If
    End If
Next
End With
If NH > 3 Then NH = 3
Label70.Caption = PH(NH)
Label72.Caption = NM * PM
End Sub

nécessite de rajouter un appel à cette sub:
-en fin de Private Sub T1_Click() pour afficher les prix dès le choix d'un nom
-pour les combobox 6 à 13 (Private Sub T6_Change(), Private Sub T7_Change()...) pour mettre à jour les prix si rajout ou suppression de cours

les prix des cours hebdo ou mensuels s'affichent dans les Label70 et Label72 (à rajouter dans l'USF),
mais on pourrait affecter ces montants à des variables et les utiliser pour un calcul du montant global.

A+

Bonjour Paf
J'ai intégré ta macro, et elle fonctionne très bien. Je t'en remercie. C'est même déconcertant….pour un novice en VBA comme moi !
Bon, seulement j'ai un correctif à y apporter...peux tu m'aider ?
Voilà, les cours mensuels, ca ne bouge pas.
Il y a juste un ajustement dans les cours hebdos. J'aurai besoin de deux sous catégories, toujours en tarif dégressif
la macro que tu m'a fourni liste les cours hebdomadaires en NH. et les prix associés en PH
Jusque là OK…
J'aurai besoin de la même chose avec cette fois-ci un distingo comme suit :
- Cours hebdo adultes qu'on pourrait nommer CHA, avec une base prix adulte variable PAH '

PAH = Array(0, 200, 360, 520) ' tableau prix adulte hebdo​

- Cours hebdo enfants qu'on pourrait nommer CHE, avec une base prix enfants variable PEH '

PEH = Array(0, 180 340, 400) ' tableau prix hebdo enfants​

mes cours adultes hebdo seraient rérérencés en feuille "Critères" colonne G
mes cours enfants hebdo seraient référencés en feuille "Critères" colonne H
Enfin mes cours mensuels qui eux restent inchangés s

eraient référencés en feuille "Critères" colonne I

Merci de ton aide !! ​