XL 2013 Incrémentation situation avec pourcentage (Résolu par JOB75)

susaita

XLDnaute Occasionnel
Bonjour le forum,

dans le fichier ci-joint j'ai essayé d'appliqué le même code fourni par JOB75 dans mon dernier post mais je trouve qu'il est un peu différent vu que je suis novice en VBA.
dans ce tableau en passant de SIT-00 que j'ai considéré comme feuille de début un message me demande de saisir le pourcentage souhaité et en mettant par exemple 40% il doit appliqué ce pourcentage sur les cellules E22 et E34 de SIT-01 qui va se créer et dans SIT-02 si je mets 45% il fera la même chose en prenant ce pourcentage du montant de la colonne E (onglet echeance) pour E22 et la colone F pour E34
dans Sit-03 si je met 15% il va prendre le reste du montant comme ça le total sera a 100% . donc dans SIT-04 le pourcentage que je saisirai il va le prendre de la ligne 16 de l'onglet Echeancier puisque on est déjà a 100 de la ligne 15 dans les trois premières situations.

dan sit-03 si je mets par exemple plus que 15% chose qui dépasse les 100% de la 1ere situation un message doit m'avertir que j'ai dépassé 100% de la situation en cours

le mois que j'ai sur B22 doit être le même de A12 que je saisirai à la main

Merci d'avance
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour susaita,

Pas cherché à comprendre : en tombant sur le message "Le nom _key2 existe déjà." j'ai refermé aussi sec le fichier.

C'est le nième projet que vous présentez, vous en faites collection ?

Et en mettant "Pour JOB75" dans le titre vous risquez de n'avoir aucune autre réponse que la mienne.
 

susaita

XLDnaute Occasionnel
Bonjour job, le forum
aufait c'est le dernier fichier que je présente en fin mois avec les autres,
pour le titre je croyais qu'en mettant <<pour...>> serait plus facile pour la personne qui a déjà travaillé dessus,
je m'excuse
 
Dernière édition:

susaita

XLDnaute Occasionnel
re,
j'ai retelechargé le fichier en copiant la trame dans un classeur propre pour éviter le message "Le nom _key2 existe déjà."
 

job75

XLDnaute Barbatruc
Bonjour susaita, le forum,

Voyez le fichier joint et ce code :
Code:
Function MoisFormule$(c As Range, Optional incremente As Boolean, Optional formule As Boolean)
'utilisée dans la macro Situation et en B22 de la feuille de calcul
Dim txt$, i%, j%, dat$
txt = c.Formula
For i = 1 To Len(txt)
    If IsNumeric(Mid(txt, i, 1)) Then Exit For '1er chiffre
Next
For j = Len(txt) To 1 Step -1
    If IsNumeric(Mid(txt, j, 1)) Then Exit For 'dernier chiffre
Next
If j > i Then dat = Mid(txt, i, j - i + 1)
If Not IsDate(dat) Then Exit Function
If formule Then
  MoisFormule = Left(txt, i - 1) & Format(DateSerial(Year(dat), Month(dat) + 2, 0), "dd-mm-yyyy") & Mid(txt, i + Len(dat))
Else
  MoisFormule = UCase(Format(DateAdd("m", -incremente, dat), "mmmm yyyy"))
End If
End Function

Sub Situation()
Dim w As Worksheet, txt$, n%, OldName$, s1#, s2#, lig, pctmax#, colE, colF, numero$, pct#, vis
For Each w In Worksheets
  If Left(w.Name, 4) = "SIT-" Then If Left(w.Name, 6) > txt Then txt = Left(w.Name, 6)
Next
If txt = "" Then Exit Sub
For Each w In Worksheets
  If Left(w.Name, 7) = txt & "-" Then
    If Val(Mid(w.Name, 8)) > n Then
      n = Val(Mid(w.Name, 8))
      OldName = txt & "-" & n
      s1 = s1 + w.[E22]
      s2 = s2 + w.[E34]
    End If
  End If
Next
If n = 0 Then OldName = txt
With Sheets("ECHEANCIER")
  lig = Application.Match(Val(Mid(txt, 5, 2)), .[B:B], 0)
  If IsError(lig) Then Exit Sub
  pctmax = Application.Round(100 * (1 - s1 / IIf(.Cells(lig, "E") = "", 1, .Cells(lig, "E"))), 2)
  If pctmax = 0 Then n = 0: pctmax = 100: s1 = 0: s2 = 0
  If pctmax = 100 Then lig = lig + 1 'nouvelle tranche de travaux
  colE = .Cells(lig, "E")
  colF = .Cells(lig, "F")
  numero = Format(.Cells(lig, "B"), "00")
End With
Do
  txt = InputBox("Entrez le % des travaux réalisés ce mois :", _
    "SITUATION N° " & numero & IIf(n, "-" & n + 1, "") & " # FIN " & MoisFormule(Sheets(OldName).[A12], True), pctmax)
  If txt = "" Then Exit Sub
  pct = Application.Round(Abs(Val(Replace(Replace(txt, ",", "."), "%", ""))), 2)
Loop While pct > pctmax
Application.ScreenUpdating = False
Application.Goto ActiveSheet.[A1], True 'cadrage
'ThisWorkbook.Unprotect "susaita" 'déprotection du classeur, mdp à adapter
With Sheets(OldName)
    vis = .Visible
    .Visible = True 'si la feuille est masquée
    .Copy After:=Sheets(Sheets.Count)
    .Visible = vis
End With
With Sheets(Sheets.Count)
  '.Protect "susaita", UserInterfaceOnly:=True 'protection de la nouvelle feuille, mdp à adapter
  .Name = "SIT-" & numero & IIf(n Or pct < 100, "-" & n + 1, "")
  txt = MoisFormule(.[A12], True, True)
  If txt = "" Then
    MsgBox "Revoyez la formule en A12..."
  Else
    .[A12] = txt
  End If
  .[D22] = "='" & OldName & "'!C22"
  .[E22] = IIf(pct = pctmax, colE - s1, Application.Round(colE * pct / 100, 2))
  .[D34] = "='" & OldName & "'!C34"
  .[E34] = IIf(pct = pctmax, colF - s2, Application.Round(colF * pct / 100, 2))
  Application.Goto .[A1], True 'cadrage
End With
'ThisWorkbook.Protect "susaita" 'protection du classeur, mdp à adapter
End Sub
J'ai mis en commentaires les 3 lignes de code pour les protections du classeur et de la feuille créée.

A vous de voir susaita si vous voulez les utiliser.

Mais à mon avis il est plus prudent de les utiliser, même si vous êtes le seul utilisateur du fichier.

Bonne soirée.
 

Fichiers joints

Dernière édition:

susaita

XLDnaute Occasionnel
Bonsoir Job, le forum
merci infiniment pour le code c'est exactement ce que je souhaitais avoir,
il reste juste un seul point que j'ai oubliéqui concerne la cellule A12 :
chaque fin mois je saisirai cette date à la main et cette dernière elle est variable ça peut être 21 comme le 29 du mois,
et pour la changer à la main c'est stupide de séléctionner cette formule ="AU "&MAJUSCULE(TEXTE("30-04-2015";"jj mmmm aaaa")) pour changer la partie 30-04-2016 par la date souhaitée...
il est possible de faire un double clique et saisir dans un message affiché la date souhaité pour avoir sur la cellule A12 : (AU...+ la date saisie sur le message) ??
si non qu'est ce que vous proposez


EDIT: comme vous pouvez constatez sur le fichier joint.en passant de Sit-01-2 a SIT-02 j'ai saisi 100% alors que le résultat n'est pas à 100%. dans E22 je dois avoir 7000000 et E34 -420000 que j'ai eu dans la colonne Cumul alors que dans cette dernière je devrais avoir dans C22=11000000 et C34= -660000

merci encore une autre fois
Bonne soirée
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re,

Il y avait en effet une petite erreur dans la macro Situation du post #5.

Je l'ai corrigée ainsi que le fichier (1).

Quant à ceci :
et pour la changer à la main c'est stupide de séléctionner cette formule ="AU "&MAJUSCULE(TEXTE("30-04-2015";"jj mmmm aaaa")) pour changer la partie 30-04-2016 par la date souhaitée...
il est possible de faire un double clique et saisir dans un message affiché la date souhaité
vous êtes un peu obsédé par le double-clic il me semble.

Il n'est pas du tout stupide de modifier la formule en A12, et c'est bien plus simple que d'y faire un double-clic.

En plus de la date vous pouvez si vous le voulez modifier son format et même le texte qui la précède, c'est prévu dans la fonction MoisFormule.

Bonne nuit.
 

job75

XLDnaute Barbatruc
Bonjour susaita, le forum,

Dans ce fichier (2) la variable incremente est un nombre de mois, c'est plus logique.

Si vous voulez que l'échéance en E47 soit à 45 jours fin de mois entrez-y la formule :
Code:
=MoisFormule(A12;1)+44
Edit : un lien utile :

http://finance-technique.com/calculer-des-delais-de-paiement-et-decheances/

Bonne journée.
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re,

Si en plus du mois on veut récupérer la date elle-même on peut rendre la fonction matricielle :
Code:
Function MoisFormule(c As Range, Optional incremente&, Optional formule As Boolean)
'utilisée dans la macro Situation et en B22-E47 de la feuille de calcul
Dim txt$, i%, j%, dat$, a(1 To 2)
txt = c.Formula
For i = 1 To Len(txt)
    If IsNumeric(Mid(txt, i, 1)) Then Exit For '1er chiffre
Next
For j = Len(txt) To 1 Step -1
    If IsNumeric(Mid(txt, j, 1)) Then Exit For 'dernier chiffre
Next
If j > i Then dat = Mid(txt, i, j - i + 1)
If Not IsDate(dat) Then MoisFormule = "": Exit Function
If formule Then
  a(1) = Left(txt, i - 1) & Format(DateSerial(Year(dat), Month(dat) + incremente + 1, 0), "dd-mm-yyyy") & Mid(txt, i + Len(dat))
Else
  a(1) = UCase(Format(DateAdd("m", incremente, dat), "mmmm yyyy"))
End If
a(2) = CDate(dat)
MoisFormule = a 'vecteur horizontal
End Function
Par exemple en E47 pour l'autre manière légale de calculer les 45 jours fin de mois :
Code:
=FIN.MOIS(INDEX(MoisFormule(A12);2)+45;0)
Fichier (3).

A+
 

Fichiers joints

Dernière édition:

susaita

XLDnaute Occasionnel
Bonjour Job,
merci beaucoup pour l'importance que vous avez donné à ce sujet mais je n'ai vraiment pas compris qu'elle est la différence entre le dernier fichier posté hier et les deux que vous avez aujourd’hui ...
 

job75

XLDnaute Barbatruc
Re,

J'ai pourtant bien précisé à chaque fois ce que fait la fonction MoisFormule !

Et pour terminer voyez ce fichier (4).

On considère qu'une facture émise avant le 15 du mois traite les travaux du mois précédent :
Code:
Function MoisFormule(c As Range, Optional incremente&, Optional formule As Boolean)
'utilisée dans la macro Situation et en B22-E47 de la feuille de calcul
Dim txt$, i%, j%, dat$, a(1 To 2)
txt = c.Formula
For i = 1 To Len(txt)
    If IsNumeric(Mid(txt, i, 1)) Then Exit For '1er chiffre
Next
For j = Len(txt) To 1 Step -1
    If IsNumeric(Mid(txt, j, 1)) Then Exit For 'dernier chiffre
Next
If j > i Then dat = Mid(txt, i, j - i + 1)
If Not IsDate(dat) Then MoisFormule = "": Exit Function
incremente = incremente + (Day(dat) < 15)
If formule Then
  a(1) = Left(txt, i - 1) & Format(DateSerial(Year(dat), Month(dat) + incremente + 1, 0), "dd-mm-yyyy") & Mid(txt, i + Len(dat))
Else
  a(1) = UCase(Format(DateAdd("m", incremente, dat), "mmmm yyyy"))
End If
a(2) = CDate(dat)
MoisFormule = a 'vecteur horizontal
End Function
A+
 

Fichiers joints

BoixosNois

XLDnaute Nouveau
Bonsoir Job75, Susaita, le forum

en voulant m'inspirer de ce joli code pour l'appliquer sur un modèle de facture et même si j'ai pris le même tableau échéancier de votre exemple le résultat = 0 :( vu que je suis novice en VBA
mais dans ma facture que je vous joint je n'ai pas le A12 ni B22 et je ne souhaite pas copier l'ancien le cumul ...
les deux cellules dont je veux appliquer le pourcentage sont : C23 et C24
la date et le numéro de facture je préfère les saisir à la main
pouvez vous me donner un coup de main si ça vous intéresse???

Bonne nuit
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour le forum,
Bonsoir Job75, Susaita, le forum

en voulant m'inspirer de ce joli code pour l'appliquer sur un modèle de facture et même si j'ai pris le même tableau échéancier de votre exemple le résultat = 0 :( vu que je suis novice en VBA
mais dans ma facture que je vous joint je n'ai pas le A12 ni B22 et je ne souhaite pas copier l'ancien le cumul ...
les deux cellules dont je veux appliquer le pourcentage sont : C23 et C24
la date et le numéro de facture je préfère les saisir à la main
pouvez vous me donner un coup de main si ça vous intéresse???

Bonne nuit
On sait, on sait BoisxosNois alias susaita etc...

Pour ceux qui ne sont pas au courant des divers pseudos utilisés :

http://www.excel-downloads.com/threads/hchhvkkfe.20010637/

Ce genre de chose ça se soigne.

Bonne journée.
 
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Cela dit il n'est vraiment pas difficile d'adapter la macro déjà donnée :
Code:
Sub Facture()
Dim w As Worksheet, txt$, n%, OldName$, s1#, s2#, lig, pctmax#, colC, colE, colF, numero$, pct#, vis
For Each w In Worksheets
  If Left(w.Name, 4) = "FAC-" Then If Left(w.Name, 6) > txt Then txt = Left(w.Name, 6)
Next
If txt = "" Then Exit Sub
For Each w In Worksheets
  If Left(w.Name, 7) = txt & "-" Then
    If Val(Mid(w.Name, 8)) > n Then
      n = Val(Mid(w.Name, 8))
      OldName = txt & "-" & n
      s1 = s1 + w.[C23]
      s2 = s2 + w.[C24]
    End If
  End If
Next
If n = 0 Then OldName = txt
With Sheets("ECHEANCIER")
  lig = Application.Match(Val(Mid(txt, 5, 2)), .[B:B], 0)
  If IsError(lig) Then Exit Sub
  pctmax = Application.Round(100 * (1 - s1 / IIf(.Cells(lig, "E") = "", 1, .Cells(lig, "E"))), 2)
  If pctmax = 0 Then n = 0: pctmax = 100: s1 = 0: s2 = 0
  If pctmax = 100 Then lig = lig + 1 'nouvelle tranche de travaux
  colC = .Cells(lig, "C")
  colE = .Cells(lig, "E")
  colF = .Cells(lig, "F")
  numero = Format(.Cells(lig, "B"), "00")
  If Not numero Like "##" Then Exit Sub 'si les derniers travaux ont été réalisés
End With
Do
  txt = InputBox("Entrez le % des travaux réalisés :", "FAC-" & numero & IIf(n, "-" & n + 1, ""), pctmax)
  If txt = "" Then Exit Sub
  pct = Application.Round(Abs(Val(Replace(Replace(txt, ",", "."), "%", ""))), 2)
Loop While pct > pctmax
Application.ScreenUpdating = False
Application.Goto ActiveSheet.[A1], True 'cadrage
'ThisWorkbook.Unprotect "BoixosNois" 'déprotection du classeur, mdp à adapter
With Sheets(OldName)
    vis = .Visible
    .Visible = True 'si la feuille est masquée
    .Copy After:=Sheets(Sheets.Count)
    .Visible = vis
End With
With Sheets(Sheets.Count)
  '.Protect "BoixosNois", UserInterfaceOnly:=True 'protection de la nouvelle feuille, mdp à adapter
  .Name = "FAC-" & numero & IIf(n Or pct < 100, "-" & n + 1, "")
  .[B23] = UCase(colC)
  .[C23] = IIf(pct = pctmax, colE - s1, Application.Round(colE * pct / 100, 2))
  .[C24] = IIf(pct = pctmax, colF - s2, Application.Round(colF * pct / 100, 2))
  Application.Goto .[A1], True 'cadrage
End With
'ThisWorkbook.Protect "BoixosNois" 'protection du classeur, mdp à adapter
End Sub
Bien sûr compte tenu de ceci :
la date et le numéro de facture je préfère les saisir à la main
je ne me suis pas occupé de l'incrémentation des cellules A10 et E8.

Fichier joint.

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re,

Pour éviter l'ouverture de l'InputBox une fois les derniers travaux réalisés, il faut ajouter dans le code :
Code:
  If Not numero Like "##" Then Exit Sub 'si les derniers travaux ont été réalisés
J'ai seulement corrigé les fichiers Situation(4) et SETEL IMMO(1).

A+
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas