youpi457032
XLDnaute Occasionnel
Bonjour,
Je suis à la recherche d'une macro VBA qui calculerait selon deux critères :
cours à l unité 30 euros de 1 à 4 cours
pass 5 cours à 140 euros
pass 10 cours à 250 euros
ce cours s'apelle EMS
j 'ai déjà une macro qui calcule différents tarifs
je la joins ici
[/macro]
'Macro Faite par DESVIGNE Christophe le 30/05/2019
Option Explicit
Dim acompte As Integer
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 37
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 37
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 37
Controls("T" & I) = Feuil5.Cells(Lig, I).Value
Next I
End If
Call PrixCoursAdulte
End Sub
Private Sub T25_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T26_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T27_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T28_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T29_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T6_Change()
Call PrixCoursAdulte
End Sub
Private Sub T7_Change()
Call PrixCoursAdulte
End Sub
Private Sub T8_Change()
Call PrixCoursAdulte
End Sub
Private Sub T9_Change()
Call PrixCoursAdulte
End Sub
Private Sub T10_Change()
Call PrixCoursAdulte
End Sub
Private Sub T11_Change()
Call PrixCoursAdulte
End Sub
Private Sub T12_Change()
Call PrixCoursAdulte
End Sub
Private Sub T13_Change()
Call PrixCoursAdulte
End Sub
Private Sub T14_Change()
Call PrixCoursAdulte
End Sub
Private Sub T15_Change()
Call PrixCoursAdulte
End Sub
Private Sub T16_Change()
Call PrixCoursAdulte
End Sub
Private Sub T17_Change()
Call PrixCoursAdulte
End Sub
Private Sub UserForm_Initialize()
Worksheets("facturation").Range("F2:Q600").Value = Worksheets("base_MALAFRETAZ").Range("W2:AH600").Value
Worksheets("facturation").Range("A2
600").Value = Worksheets("base_MALAFRETAZ").Range("A2600").Value
Worksheets("facturation").Range("E2:E600").Value = Worksheets("base_MALAFRETAZ").Range("AI2:AI600").Value
Dim aa, fin&, I&
With Feuil5
fin = .Range("A" & Rows.Count).End(3).Row
If fin < 2 Then Exit Sub
aa = .Range("A2:AI" & 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 17
Controls("T" & I).List = Feuil2.Range("A2:A" & Feuil2.Range("A" & Rows.Count).End(3).Row).Value
Next I
For I = 18 To 24
Controls("T" & I).List = Feuil2.Range("E2:E" & Feuil2.Range("E" & Rows.Count).End(3).Row).Value
Next I
End Sub
Private Sub PrixCoursAdulte()
Dim I, z As Integer, M As Boolean, NM As Integer, NH As Integer
Dim PEV, PCM As Integer
Dim PA, EH, NE, NEnF
Dim CA, CE As Boolean
Dim tarif As String
Dim acompte As Integer
PEV = 170 'prix cours " eveil a la danse 4/6 ans"
PCM = 180 'prix des cours mensuels
PA = Array(0, 210, 380, 530, 660) 'prix des cours adulte hebdo degressif
EH = Array(0, 190, 335, 460, 565) 'prix des cours enfants hebdo degressif a rajouter
'EMS = Array(0, 30, 140, 250)
With Worksheets("Crit?res")
For I = 6 To 17
M = False
If Controls("T" & I).ListIndex <> -1 Then
For z = 2 To .Range("G" & Rows.Count).End(xlUp).Row 'Cours mensuels
If .Range("J" & z) = Controls("T" & I) Then
tarif = "mensu"
Exit For
End If
If .Range("K" & z) = Controls("T" & I) Then 'cours adultes
tarif = "adulte"
Exit For
End If
If .Range("I" & z) = Controls("T" & I) Then 'cours enfants
tarif = "enfant"
Exit For
End If
If .Range("H" & z) = Controls("T" & I) Then 'cours eveil
tarif = "eveil"
Exit For
End If
Next
Select Case tarif
Case "mensu"
NM = NM + 1
Case "enfant"
NEnF = NEnF + 1
Case "adulte"
NH = NH + 1
Case "eveil"
NE = NE + 1
End Select
End If
Next
End With
If NH > 4 Then NH = 4
T34 = PA(NH) 'Total cours adultes
If NM > 5 Then NM = 5
T35 = NM * PCM 'total cours mensuels
T32 = NE * PEV ' total cours ?veil 4/6 ans
If NEnF > 3 Then NEnF = 3
T33.Value = EH(NEnF) 'total cours primaires / coll?ge
' calcul du total
T37.Value = (Val(T32) + Val(T33) + Val(T34.Value) + Val(T35)) - Val(T36.Value)
End Sub
[\MACRO -end ]
donc l'idée, c'est de compléter cette macro avec le calcul des cours EMS
Je l'associerai à un contrôle T38, comme j'ai associé les autres cours adultes, enfants, mensuels….etc...
seul difficulté, je ne peux pas mettre un simple EMS = Array (0, 30, 140,250), puisque que chaque cours de 1 à 4 cours doit aussi être calculer à l'unité (soit 120 euros max pour 4 cours max). Dès qu'on passe à 5 cours prix de 140 euros, et forfait 10 cours 250 euros.
Excemple si un élève prend :
1 cours : 30 euros
2 cours 60...., 3 cours 90, 4 cours...120.
5 cours : pass à 140 euros
6 cours : pass à 140 + 1 cours à 30 euros
8 cours : pass à 140 + 3 cours à 30 euros
10 cours pass à 250 euros
12 cours pass à 250 euros + 2 cours à 30
15 cours pass à 250 + pass à 5 cours….
etc.… pour la logique du calcul...
comment mettre en forme ce calcul VBA ?
bien evidemment je rajouterai un contrôle Text (userform) pour renseigner le nombre de cours (exemple T40)
Merci
Je suis à la recherche d'une macro VBA qui calculerait selon deux critères :
cours à l unité 30 euros de 1 à 4 cours
pass 5 cours à 140 euros
pass 10 cours à 250 euros
ce cours s'apelle EMS
j 'ai déjà une macro qui calcule différents tarifs
je la joins ici
[/macro]
'Macro Faite par DESVIGNE Christophe le 30/05/2019
Option Explicit
Dim acompte As Integer
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 37
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 37
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 37
Controls("T" & I) = Feuil5.Cells(Lig, I).Value
Next I
End If
Call PrixCoursAdulte
End Sub
Private Sub T25_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T26_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T27_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T28_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T29_Change()
acompte = Val(T25) + Val(T26) + Val(T27) + Val(T28) + Val(T29)
T36.Value = acompte
End Sub
Private Sub T6_Change()
Call PrixCoursAdulte
End Sub
Private Sub T7_Change()
Call PrixCoursAdulte
End Sub
Private Sub T8_Change()
Call PrixCoursAdulte
End Sub
Private Sub T9_Change()
Call PrixCoursAdulte
End Sub
Private Sub T10_Change()
Call PrixCoursAdulte
End Sub
Private Sub T11_Change()
Call PrixCoursAdulte
End Sub
Private Sub T12_Change()
Call PrixCoursAdulte
End Sub
Private Sub T13_Change()
Call PrixCoursAdulte
End Sub
Private Sub T14_Change()
Call PrixCoursAdulte
End Sub
Private Sub T15_Change()
Call PrixCoursAdulte
End Sub
Private Sub T16_Change()
Call PrixCoursAdulte
End Sub
Private Sub T17_Change()
Call PrixCoursAdulte
End Sub
Private Sub UserForm_Initialize()
Worksheets("facturation").Range("F2:Q600").Value = Worksheets("base_MALAFRETAZ").Range("W2:AH600").Value
Worksheets("facturation").Range("A2
600").Value = Worksheets("base_MALAFRETAZ").Range("A2600").ValueWorksheets("facturation").Range("E2:E600").Value = Worksheets("base_MALAFRETAZ").Range("AI2:AI600").Value
Dim aa, fin&, I&
With Feuil5
fin = .Range("A" & Rows.Count).End(3).Row
If fin < 2 Then Exit Sub
aa = .Range("A2:AI" & 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 17
Controls("T" & I).List = Feuil2.Range("A2:A" & Feuil2.Range("A" & Rows.Count).End(3).Row).Value
Next I
For I = 18 To 24
Controls("T" & I).List = Feuil2.Range("E2:E" & Feuil2.Range("E" & Rows.Count).End(3).Row).Value
Next I
End Sub
Private Sub PrixCoursAdulte()
Dim I, z As Integer, M As Boolean, NM As Integer, NH As Integer
Dim PEV, PCM As Integer
Dim PA, EH, NE, NEnF
Dim CA, CE As Boolean
Dim tarif As String
Dim acompte As Integer
PEV = 170 'prix cours " eveil a la danse 4/6 ans"
PCM = 180 'prix des cours mensuels
PA = Array(0, 210, 380, 530, 660) 'prix des cours adulte hebdo degressif
EH = Array(0, 190, 335, 460, 565) 'prix des cours enfants hebdo degressif a rajouter
'EMS = Array(0, 30, 140, 250)
With Worksheets("Crit?res")
For I = 6 To 17
M = False
If Controls("T" & I).ListIndex <> -1 Then
For z = 2 To .Range("G" & Rows.Count).End(xlUp).Row 'Cours mensuels
If .Range("J" & z) = Controls("T" & I) Then
tarif = "mensu"
Exit For
End If
If .Range("K" & z) = Controls("T" & I) Then 'cours adultes
tarif = "adulte"
Exit For
End If
If .Range("I" & z) = Controls("T" & I) Then 'cours enfants
tarif = "enfant"
Exit For
End If
If .Range("H" & z) = Controls("T" & I) Then 'cours eveil
tarif = "eveil"
Exit For
End If
Next
Select Case tarif
Case "mensu"
NM = NM + 1
Case "enfant"
NEnF = NEnF + 1
Case "adulte"
NH = NH + 1
Case "eveil"
NE = NE + 1
End Select
End If
Next
End With
If NH > 4 Then NH = 4
T34 = PA(NH) 'Total cours adultes
If NM > 5 Then NM = 5
T35 = NM * PCM 'total cours mensuels
T32 = NE * PEV ' total cours ?veil 4/6 ans
If NEnF > 3 Then NEnF = 3
T33.Value = EH(NEnF) 'total cours primaires / coll?ge
' calcul du total
T37.Value = (Val(T32) + Val(T33) + Val(T34.Value) + Val(T35)) - Val(T36.Value)
End Sub
[\MACRO -end ]
donc l'idée, c'est de compléter cette macro avec le calcul des cours EMS
Je l'associerai à un contrôle T38, comme j'ai associé les autres cours adultes, enfants, mensuels….etc...
seul difficulté, je ne peux pas mettre un simple EMS = Array (0, 30, 140,250), puisque que chaque cours de 1 à 4 cours doit aussi être calculer à l'unité (soit 120 euros max pour 4 cours max). Dès qu'on passe à 5 cours prix de 140 euros, et forfait 10 cours 250 euros.
Excemple si un élève prend :
1 cours : 30 euros
2 cours 60...., 3 cours 90, 4 cours...120.
5 cours : pass à 140 euros
6 cours : pass à 140 + 1 cours à 30 euros
8 cours : pass à 140 + 3 cours à 30 euros
10 cours pass à 250 euros
12 cours pass à 250 euros + 2 cours à 30
15 cours pass à 250 + pass à 5 cours….
etc.… pour la logique du calcul...
comment mettre en forme ce calcul VBA ?
bien evidemment je rajouterai un contrôle Text (userform) pour renseigner le nombre de cours (exemple T40)
Merci
