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

susaita · 12 Septembre 2016

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

job75 · 15 Septembre 2016

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 :

BoixosNois à dit:
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+

job75 · 15 Septembre 2016

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+

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

susaita

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Discussions similaires