VBA Excel problème de répartissions Fermé

Question

Bonjour,

J'ai créer un UserForm qui permet de remplir un tableau dans lequel on trouve entre autre une colonne avec un montant, une autre colonne avec la date de début de chantier et une 3ème colonne avec la durée prévisionnel du chantier en mois. Ensuite j'ai un mois par colonne pendant X années.

Ayant quelques connaissances sur VBA Excel j'arrive a remplir le tableau. Il me manque juste une fonction, que je n'arrive pas à trouver, qui permet de répartir le montant par mois selon le nombre de mois saisies.
Pour l'instant, avec la programmation que j'ai effectuée, j'arrive à selectionner la cellule correspondant à la date de début de chantier saisie et d'y mettre la valeur du montant diviser par le nombre de mois. Il faudrait ensuite répartir ce montant dans les mois qui suivent selon le nombre de mois saisie dans l'UserForm.

Si quelqu'un pourrait m'aider. Je vous joint la programmation que j'ai déja effectuée.
Si mes explications ne sont pas claires dites le moi j'essairai d'expliquer autrement.
Merci d'avance.

Voici le code de l'UserForm:

For i = 9 To 256
datesaisie = DateValue(DatePRO)
   If Cells(6, i) = datesaisie Then
        If Cells(n, 4) = "" Then
   Cells(n, i) = Cells(n, 3).Value / Val(DuréePRO)
        Else
   Cells(n, i) = Cells(n, 4).Value / Val(DuréePRO)
        End If
   Exit For
   End If
   Next i
   
For j = 9 To 256
Datesaisie1 = DateValue(DateChantier)
If Cells(6, j) = Datesaisie1 Then
        If Cells(n, 7) = "" Then
   Cells(n, j) = Cells(n, 6).Value / Val(DuréeChantier)
'La fonction manquante qui permet de répartir le montant se trouverai ici
        Else
   Cells(n, j) = Cells(n, 7).Value / Val(DuréeChantier)
        End If
   Exit For
   End If
   Next j
   
Exit For
End If
Next n

 Exit Sub
erreur_planning:
  If Err = 13 Then
  MsgBox " Vous devez taper une date PRO et une date Chantier "
  End If
  
Range("A1").Select
Previssionnel.Hide
Unload Previssionnel
End Sub

lermite222 · Answer

Bonjour,
Je ne comprebd pas très bien,
Tu aurais un montant .. ex: 1000 à répartir sur un nombre de mois ?
Mais le nombre de mois est tributaire des jours ex : du 31/1 au 1/2 il y a deux mois ? mais seulement 2 jours ?
Tu dis...
A+

lermite222 · Answer

Une macro qui calcule la répartition en fonction des dates et des jours, si tu ne veux pas répartir en jour tu met DatDeb avec par exemple 1/1/2009 et dans datFin 31/7/2009
Mais supporte la répartition pondérée sur des dates complète comme 10/1/2009 au 21/7/2009
Sub RépartirMontant()
Dim Ddep As Long, Dr  As Date
Dim DatDep As Date, DatFin As Date
Dim Montant As Single, Repartit As Single
Dim Buf As Byte, Lig As Long

    'exemple:
    Montant = 12000
    DatDep = "10/1/2009"
    DatFin = "21/7/2009"
    'calcul le nombre de jour en tout = 192 dans l'exemple
    Ddep = DateValue(DatFin) - DateValue(DatDep) + 1
    Repartit = Montant / Ddep 'répartit le montant sur le nombre de jours
    Lig = 3
    'Montant pour janvier
    Buf = calculJourMois(DatDep) - Day(DatDep) + 1
    With Sheets("feuil1")
        .Cells(Lig, 3) = Buf * Repartit
        For i = Month(DatDep) + 1 To Month(DatFin) - 1
            Lig = Lig + 1
            Dr = DateSerial(Year(DatDep), i, 1)
            Buf = calculJourMois(Dr)
            .Cells(Lig, 3) = Buf * Repartit
        Next i
        'Montant pour juillet
        Buf = calculJourMois(DatFin) - Day(DatFin)
        .Cells(Lig + 1, 3) = Day(DatFin) * Repartit
    End With
End Sub
Function calculJourMois(D As Date) As Byte
Dim D1 As Long, D2 As Long
Dim Mois As Integer
    D1 = DateSerial(Year(D), Month(D), 1)
    If Month(D) < 12 Then
        calculJourMois = DateSerial(Year(D), Month(D) + 1, 1) - D1
    Else
        calculJourMois = DateSerial(Year(D) + 1, 1, 1) - D1
    End If
End Function

Tu dis...
A+
PS: je n'ai pas pris en compte un éventuel changement d'année.
Si ce devait être le cas il faudra adapter.