Pointage des X devenant des P ( RESOLU )

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion JBARBE
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
JBARBE

JBARBE

XLDnaute Barbatruc
Bonjour à tous,

J'ai fait une macro qui marche mais qui doit ramer sur plusieurs lignes !

Je m'explique : Lorsque je clic sur le bouton "pointage" alors que le solde total est vide, celui-ci se rempli !

Ensuite j'ai la colonne à côté "pointage des P" qui se rempli lorsque je mets des "X" dans la colonne A et que le clic à nouveau sur le bouton " pointage"!

Je voudrais savoir si une macro plus rapide peut-être faite avec les fonctions qui lui sont attribués dans mon exemple !

Code: 
Option Explicit

Sub Pointage_des_X()
Dim I As Long
 Application.ScreenUpdating = False
 Range("Effacer").ClearContents
 Range("H1") = Range("E1")
 If Cells(4, 1) = "" Then
   Cells(4, 9) = Range("H1") + Cells(4, 6) - Cells(4, 5)
  Cells(4, 9).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
  ElseIf Cells(4, 1) = "P" Then
   Cells(4, 9) = Range("H1") + Cells(4, 6) - Cells(4, 5)
  Cells(4, 9).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
  Cells(4, 8) = Range("H1") + Cells(4, 6) - Cells(4, 5)
  Cells(4, 8).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
  Range("H1") = Cells(4, 9)
  ElseIf Cells(4, 1) = "X" Then
     Cells(4, 8) = Range("H1") + Cells(4, 6) - Cells(4, 5)
     Cells(4, 8).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
     Cells(4, 9) = Range("H1") + Cells(4, 6) - Cells(4, 5)
     Cells(4, 9).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
      Cells(4, 1) = "P"
      Range("H1") = Cells(4, 8)
  End If
For I = 5 To 65536
   If Cells(I, 2) = "" Then Exit Sub
   If Cells(I, 1) = "" Then
     Cells(I, 9) = Cells(I - 1, 9) + Cells(I, 6) - Cells(I, 5)
     Cells(I, 9).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
   ElseIf Cells(I, 1) = "X" Then
     Cells(I, 8) = Range("H1") + Cells(I, 6) - Cells(I, 5)
     Cells(I, 8).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
     Cells(I, 9) = Cells(I - 1, 9) + Cells(I, 6) - Cells(I, 5)
     Cells(I, 9).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
     Range("H1") = Cells(I, 8)
     Cells(I, 1) = "P"
     ElseIf Cells(I, 1) = "P" Then
     Cells(I, 8) = Range("H1") + Cells(I, 6) - Cells(I, 5)
     Cells(I, 8).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
     Cells(I, 9) = Cells(I - 1, 9) + Cells(I, 6) - Cells(I, 5)
     Cells(I, 9).NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
     Range("H1") = Cells(I, 8)
   End If
Next I
 Application.ScreenUpdating = True

End Sub

J'ai modifié la macro parce qu'elle ne tenait pas compte des P déjà fait ! 18 h 30

Merci à l'avance !
 

Pièces jointes

Dernière édition:
Trier par date Trier par votes
Re : Pointage des X devenant des P

Efgé à dit:
Re
@ JBARBE



Nous sommes, peut être, d'accord sur une boucle, bien que je pense, comme tous le monde, qu'il faudrait limiter la casse (.End(3).row ou exit sub, ou.... ),mais limiter la casse.
Pär contre, si tu sélectionne tes deux colonnes, que tu applique le mondialement célèbre format ###0.00 "€";[Red]-###0.00 "€"
J'aimerais comprendre pourquoi le re mettre puis la prochaine fois le re re mettre puis le coups suivant le re re re.....
Lignes inutiles, temps rallongé..

@Staple : tu peux dormir en paix, mais tu avais bien compris que ma haine n'est que feinte, Par contre je porte Haut les couleurs du club "Des Un" 😀
Cliquez pour agrandir...

Merci Efgé, je n'y avais pas pensé !

Voici la modification !
Code: 
 Range("Effacer").ClearContents
 Range("Effacer").NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""

Code: 
Sub Pointage_X()
Dim C As Range
 Application.ScreenUpdating = False
 Range("Effacer").ClearContents
 Range("Effacer").NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
 Range("H1") = Range("E1")
 If Cells(4, 1) = "" Then
   Cells(4, 9) = Range("H1") + Cells(4, 6) - Cells(4, 5)
  ElseIf Cells(4, 1) = "P" Then
   Cells(4, 9) = Range("H1") + Cells(4, 6) - Cells(4, 5)
  Cells(4, 8) = Range("H1") + Cells(4, 6) - Cells(4, 5)
  Range("H1") = Cells(4, 9)
  ElseIf Cells(4, 1) = "X" Then
     Cells(4, 8) = Range("H1") + Cells(4, 6) - Cells(4, 5)
     Cells(4, 9) = Range("H1") + Cells(4, 6) - Cells(4, 5)
      Cells(4, 1) = "P"
      Range("H1") = Cells(4, 8)
  End If
For Each C In Range("A5:A65536")
   If C = "" And C.Offset(0, 1) <> "" Then
     C.Offset(0, 8) = C.Offset(-1, 8) + C.Offset(0, 5) - C.Offset(0, 4)
   ElseIf C = "X" And C.Offset(0, 1) <> "" Then
     C.Offset(0, 7) = Range("H1") + C.Offset(0, 5) - C.Offset(0, 4)
     C.Offset(0, 8) = C.Offset(-1, 8) + C.Offset(0, 5) - C.Offset(0, 4)
     Range("H1") = C.Offset(0, 7)
     C = "P"
     ElseIf C = "P" And C.Offset(0, 1) <> "" Then
     C.Offset(0, 7) = Range("H1") + C.Offset(0, 5) - C.Offset(0, 4)
     C.Offset(0, 8) = C.Offset(-1, 8) + C.Offset(0, 5) - C.Offset(0, 4)
     Range("H1") = C.Offset(0, 7)
     Else
     Exit Sub
   End If
Next C
 Application.ScreenUpdating = True
End Sub

bonne journée
 
Vote positif 0 Vote négatif
Re : Pointage des X devenant des P

Re
Une proposition:
Remplacer la formule du range Effacer par
=DECALER(Feuil1!$H$4;;;NB(Feuil1!$B:$B);2)
Ça limite automatiquement la plage au nombre de dates présentent en colonne B

Ensuite ce code
VB: 
Sub Pointage_X_FG()
Dim C As Range, R As Range
Set R = Range("Effacer")
Application.ScreenUpdating = False
R.ClearContents
R.NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€""" 'Bien que une fois fait sur toutes la colonne cela ne servent a rien
Range("H1") = Range("E1")


Cells(4, 9) = Range("H1") + Cells(4, 6) - Cells(4, 5)
If Cells(4, 1) <> "" Then
    Cells(4, 8) = Range("H1") + Cells(4, 6) - Cells(4, 5)
    Range("H1") = IIf(Cells(4, 1) = "P", Cells(4, 9), Cells(4, 8))
End If
If Cells(4, 1) = "X" Then Cells(4, 1) = "P"


For Each C In R.Offset(1, -7).Resize(R.Rows.Count - 1, 1)
    C.Offset(0, 8) = C.Offset(-1, 8) + C.Offset(0, 5) - C.Offset(0, 4)
    If C <> "" Then
        C.Offset(0, 7) = Range("H1") + C.Offset(0, 5) - C.Offset(0, 4)
        Range("H1") = C.Offset(0, 7)
    End If
    If C = "X" Then C = "P"
Next C


Application.ScreenUpdating = True
End Sub

Cordialement
 
Vote positif 0 Vote négatif
Re : Pointage des X devenant des P

Efgé à dit:
Re
Tu as bien modifier la formule du nom Effacer ?
Cordialement
Cliquez pour agrandir...

Petite erreur de ma part dans la formule Effacer que j'ai rectifié !

Je ne pense pas que l'on peut faire mieux sur la rapidité de la macro !

Certes la vie est chère, mais le nombre de dépenses et dans une moindre mesure les recettes (hélas!), ne dépasserons pas les 500 lignes ( fichier de 2013 ) !

Bref, ta macro comporte moins de ligne et, de fait, reste plus exploitable !

N'est-ce pas là le but recherché !

Merci encore et A+
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Pointage des X devenant des P

Re
Bonjour Job

job75 à dit:
...Bah vous n'avez jamais entendu parler de tableaux VBA (matrices) ?...
Cliquez pour agrandir...
Voila, voila, j'arrive...
VB: 
Sub Pointage_X_FG_3()
Dim R As Range, T As Variant, Var As Long, i As Long
Application.ScreenUpdating = False


With Range("Effacer")
    .ClearContents
    .NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
End With


Var = Range("E1")
With ActiveSheet
    Set R = .Range(.Cells(4, 1), .Cells(.Rows.Count, 2).End(3)(1, 8))
End With
T = R


T(1, 9) = Var + T(1, 6) - T(1, 5)
If T(1, 1) <> "" Then
    T(1, 8) = Var + T(1, 6) - T(1, 5)
    Var = IIf(T(1, 1) = "P", T(1, 9), T(1, 8))
End If
If T(1, 1) = "X" Then T(1, 1) = "P"


For i = 2 To UBound(T, 1)
    T(i, 9) = T(i - 1, 9) + T(i, 6) - T(i, 5)
    If T(i, 1) <> "" Then
        T(i, 8) = Var + T(i, 6) - T(i, 5)
        Var = T(i, 8)
    End If
    If T(i, 1) = "X" Then T(i, 1) = "P"
Next i


R = T
Range("H1") = Var


Application.ScreenUpdating = True
End Sub

Mais est-ce aussi compréhensible ?

Cordialement
 
Vote positif 0 Vote négatif
Re : Pointage des X devenant des P

Efgé à dit:
Re
Bonjour Job


Voila, voila, j'arrive...

Mais est-ce aussi compréhensible ?

Cordialement
Cliquez pour agrandir...

Certes, cette macro est une autre programmation que je n'ai jamais eu l'occasion d'apprendre( vieux bouquins Excel 2003) , mais pour peu que l'on connaisse le VBA cela reste compréhensible !

Mais dans ma demande, l'essentiel était de trouver une méthode simple et, de fait, efficace et rapide dans le calcul car il peut y avoir une demande à peu prés identique, avec des lignes pouvant s'allonger !

En tout cas, moi qui désespérait, je peux dire que je suis gâté !

Merci et bonne soirée à tous !
 
Vote positif 0 Vote négatif
Re : Pointage des X devenant des P

Efgé à dit:
Re
Bonjour Job


Voila, voila, j'arrive...
VB: 
Sub Pointage_X_FG_3()
Dim R As Range, T As Variant, Var As Long, i As Long
Application.ScreenUpdating = False


With Range("Effacer")
    .ClearContents
    .NumberFormat = "###0.00 ""€"";[Red]-###0.00 ""€"""
End With


Var = Range("E1")
With ActiveSheet
    Set R = .Range(.Cells(4, 1), .Cells(.Rows.Count, 2).End(3)(1, 8))
End With
T = R


T(1, 9) = Var + T(1, 6) - T(1, 5)
If T(1, 1) <> "" Then
    T(1, 8) = Var + T(1, 6) - T(1, 5)
    Var = IIf(T(1, 1) = "P", T(1, 9), T(1, 8))
End If
If T(1, 1) = "X" Then T(1, 1) = "P"


For i = 2 To UBound(T, 1)
    T(i, 9) = T(i - 1, 9) + T(i, 6) - T(i, 5)
    If T(i, 1) <> "" Then
        T(i, 8) = Var + T(i, 6) - T(i, 5)
        Var = T(i, 8)
    End If
    If T(i, 1) = "X" Then T(i, 1) = "P"
Next i


R = T
Range("H1") = Var


Application.ScreenUpdating = True
End Sub

Mais est-ce aussi compréhensible ?

Cordialement
Cliquez pour agrandir...

petit problème : le calcul de 1731,54 € se fait en arrondissant les Euros :
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Pointage des X devenant des P ( probléme non résolu complétement)

salut

avec un Tableau ? Une autre façon de gérer le compte (saisie et pointage seulement; échéancier, bilan ... à prévoir). Les formules sont recopiées lors d'ajout de lignes.
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Electron24
  • Résolu(e)
Microsoft 365 Virgules dans ListView
Réponses
5
Affichages
145
Electron24
Electron24
K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
243
KRUG WOO
K
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
479
CortoXls
C
P
  • Question Question
Microsoft 365 VBA et Segments TCD
Réponses
2
Affichages
201
patricko-13
P
A
  • Résolu(e)
XL 2019 Remplacer un mot et ajouter une couleur
Réponses
7
Affichages
337
Attila451
A
B
  • Question Question
Microsoft 365 Macro pour création fichier csv
Réponses
8
Affichages
466
job75
job75
F
  • Question Question
XL 2021 probleme dans la macro
Réponses
4
Affichages
177
kiki29
kiki29
F
  • Résolu(e)
Autres Insérer une ligne
2 3
Réponses
36
Affichages
2 K
francescofrancesco
F
N
  • Question Question
XL 2013 Utilisé deux CommandButton_Click dans la même feuil
Réponses
4
Affichages
108
patricktoulon
patricktoulon
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
916
laurent950
laurent950
W
  • Résolu(e)
XL 2016 Placer mes photos dans la colonne A, [A3], [A4],etc, jusqu'en [A99] selon le prénom et le nom colonnes B et C
2
Réponses
26
Affichages
407
Webperegrino
W
A
  • Question Question
XL 2019 Copie d'une valeur dans la cellule à côté d'une valeur trouvé
Réponses
1
Affichages
133
sylvanu
sylvanu
badraaliou4
  • Question Question
XL 2021 Importer les données Access dans Excel
Réponses
2
Affichages
432
badraaliou4
badraaliou4
C
  • Résolu(e)
XL 2016 MsgBox avec critères
2
Réponses
22
Affichages
596
candido57
C
M
  • Question Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
972
Mody200
M
J
  • Question Question
XL 2021 transfert listview vers feuille excel
Réponses
9
Affichages
313
Piment
P
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
643
Gestionnaire_rh
G
thunder23
  • Résolu(e)
XL 2021 And/Or dans If
Réponses
3
Affichages
328
thunder23
thunder23
VBA_dev_Anne_Marie
  • Question Question
Microsoft 365 VBA : copier les adresses
Réponses
7
Affichages
339
VBA_dev_Anne_Marie
VBA_dev_Anne_Marie
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
169
CDALE
C
Retour