Pointage des X devenant des P ( RESOLU )

JBARBE · 8 Juin 2014

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 !

camarchepas · 9 Juin 2014

Re : Pointage des X devenant des P

Bien si quand même,

a chaque tour de boucle tu testes , et même si c'est pas énorme , c'est du temps ....

Bien cordialement ,

JBARBE · 9 Juin 2014

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" 😀

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

Efgé · 9 Juin 2014

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

JBARBE · 9 Juin 2014

Re : Pointage des X devenant des P

Merci Efgé mais il y a une erreur ici :

For Each C In R.Offset(1, -7).Resize(R.Rows.Count - 1, 1)

Efgé · 9 Juin 2014

Re : Pointage des X devenant des P

Re
Tu as bien modifier la formule du nom Effacer ?
Cordialement

JBARBE · 9 Juin 2014

Re : Pointage des X devenant des P

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

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+

job75 · 9 Juin 2014

Re : Pointage des X devenant des P

Bonjour à tous,

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

Bah vous n'avez jamais entendu parler de tableaux VBA (matrices) ?

Plein d'exemples sur le forum, en particulier sur mes posts.

A+

Efgé · 9 Juin 2014

Re : Pointage des X devenant des P

Re
Bonjour Job

job75 à dit:
...Bah vous n'avez jamais entendu parler de tableaux VBA (matrices) ?...

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

JBARBE · 9 Juin 2014

Re : Pointage des X devenant des P

Efgé à dit:
Re
Bonjour Job

Voila, voila, j'arrive...

Mais est-ce aussi compréhensible ?

Cordialement

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 !

JBARBE · 9 Juin 2014

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

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

Efgé · 9 Juin 2014

Re : Pointage des X devenant des P ( probléme non résolu complétement)

Re
Utilise Var As Double
Cordialement

JBARBE · 9 Juin 2014

Re : Pointage des X devenant des P ( probléme non résolu complétement)

Efgé à dit:
Re
Utilise Var As Double
Cordialement

Je n'avais pas vu l'attribution de cette variable !

C'est OK Merci !

Si... · 10 Juin 2014

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.

Pointage des X devenant des P ( RESOLU )

JBARBE

XLDnaute Barbatruc

Pièces jointes

camarchepas

XLDnaute Barbatruc

JBARBE

XLDnaute Barbatruc

Efgé

XLDnaute Barbatruc

JBARBE

XLDnaute Barbatruc

Pièces jointes

Efgé

XLDnaute Barbatruc

JBARBE

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Efgé

XLDnaute Barbatruc

JBARBE

XLDnaute Barbatruc

JBARBE

XLDnaute Barbatruc

Pièces jointes

Efgé

XLDnaute Barbatruc

JBARBE

XLDnaute Barbatruc

Si...

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Pointage des X devenant des P ( RESOLU )

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency