compteur avec remise à 0 automatique

[netten]

Bonjour, je me présente, Eric

Je travail actuellement à la conception d'un logiciel, j'ai découvert un peu par la suite que de créer ses macro avait un intérêt des moins négligeable. Je demande un peu d'aide pour mettre fin à mon projet, ce qui donnera lieu à quelques post.

Je vais essayer de rédiger au mieux mes questions.

Donc, j'ai un fichier excel dans lequel je recense des données régulièrement, disons tout les 15 jours.

Ces données sont rentrées sur la ligne 1, j'ai réussi à faire un bouton nommé "archivage" qui permet de copier ces données rentrées sur des lignes inférieures et à chaque fois que je rentre une nouvelle ligne, elle sera archivé à la suite de la précédente,... L'action se finit avec l'effacement de la ligne 1 ou j'ai rentré initialement mes données.

Ca se complique : imaginons que les données archivées sont dans les cases A2 A3 A4 A5 A6 A7 A8, une colonne à côté calcul les différences entre deux cellules, supposons que l'opération se fasse dans la colonne G, on aura : G3 = A3-A2, G4 = A4-A3 et ainsi de suite.

les données contenues dans la colonne A sont des temps. A la fin de la colonne G est effectué une somme de cette dernière, cette somme est comparé avec une valeur de consigne. Je souhaite que lorsque la somme des cellules en G est supérieur à ma valeur de consigne, les cellule contenant une valeur différente de 0 soit effacées (cellule toujours dans la colonne G), je considère ça comme une remise à 0 de mon compteur horaire.

Cette étape est importante dans mon document car cette remise à 0 déclenchera d'autres action dans d'autres fichiers.

Ce que j'ai déjà fais : alors en fait, j'ai voulu effacer les cellule en différenciant les valeurs différentes de 0, ça n'avait pas marché, ça m'affaçait tout, j'ai donc opté pour un code de couleur, c'est à dire que chaque cellule étant supérieur à 0 se colore en vert (code de couleur : 4), et essayer de créer une formule qui finalement efface les cellules de couleur verte lorsque la somme de G >= consique (cellule à part). Ma formule doit comporter des erreurs, et c'est la que je demande votre aide.

C'est la première fois de ma vie que je touche au basic, je pense que ça peut se comprendre vite, mais je n'arrive pas à m'en sortir tout seul. Merci bien Eric


P.S : Le fichier fait 235 ko, je l'envoie très volontier via une boîte mail.

Sub ArchCEXTRUDEUSE()

Worksheets("EXTRUDEUSES").Range("B1:J1").Copy

lig = 1
Do While Worksheets("EXTRUDEUSES").Range("B4").Cells(lig, 1) <> ""
lig = lig + 1
Loop

Worksheets("EXTRUDEUSES").Range("B" & lig + 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("B1").Copy

Worksheets("COMPTEURS").Range("G2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("C1").Copy

Worksheets("COMPTEURS").Range("I2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("D1").Copy

Worksheets("COMPTEURS").Range("K2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("E1").Copy

Worksheets("COMPTEURS").Range("M2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("F1").Copy

Worksheets("COMPTEURS").Range("O2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("G1").Copy

Worksheets("COMPTEURS").Range("Q2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("H1").Copy

Worksheets("COMPTEURS").Range("S2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("I1").Copy

Worksheets("COMPTEURS").Range("U2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Worksheets("EXTRUDEUSES").Range("J1").Copy

Worksheets("COMPTEURS").Range("W2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False


Range("B1").Select
Selection.ClearContents
Range("C1").Select
Selection.ClearContents
Range("D1").Select
Selection.ClearContents
Range("E1").Select
Selection.ClearContents
Range("F1").Select
Selection.ClearContents
Range("G1").Select
Selection.ClearContents
Range("H1").Select
Selection.ClearContents
Range("I1").Select
Selection.ClearContents
Range("J1").Select
Selection.ClearContents

If K535 >= K536 - 24 And c.Interior.ColorIndex = 4 Then
For Each c In Range("$K$5:$K$534")
c.ClearContents
c.Interior.ColorIndex = xlNone
Next c

End If

c'est l que ça coince

Range("B1").Select

End Sub

 

[JNP]

Re : compteur avec remise à 0 automatique

Bonjour Netten et bienvenue ,
Il n'y a rien qui te choque là ?

[COLOR=blue][B]Range("J1").[/B][/COLOR]Select
[COLOR=black]Selection.ClearContents[/COLOR]
[COLOR=black]If [COLOR=red][B]K535[/B][/COLOR] >= [B][COLOR=red]K536[/COLOR][/B] - 24 And c.Interior.ColorIndex = 4 Then[/COLOR]
[COLOR=black]For Each c In Range("[COLOR=red][B]$[/B][/COLOR]K[COLOR=red][B]$[/B][/COLOR]5:[COLOR=red][B]$[/B][/COLOR]K[COLOR=red][B]$[/B][/COLOR]534")[/COLOR]

Tu ne penses pas que

If [COLOR=red][B]Range("K535")[/B][/COLOR] >= [COLOR=red][B]Range("K536")[/B][/COLOR] - 24 And c.Interior.ColorIndex = 4 Then
[COLOR=black]For Each c In Range("K5:K534")[/COLOR]

serait plus logique .
Bon courage

 

[netten]

Re : compteur avec remise à 0 automatique

ah oui, j'essaie tout de suite ^^. J'avais mis ça parce que j'avais vu des formule sur le net ou "range" n'apparaissait pas alors j'avais tendance à croire que ça pouvait marcher aussi

 

[netten]

Re : compteur avec remise à 0 automatique

Ah, je viens de corriger et j'ai fais un essai, il me donne le message suivant :

objet requis

 

[Efgé]

Re : compteur avec remise à 0 automatique

Bonjour netten, JNP ,
Il y a un autre problème :

If K535 >= K536 - 24 And [COLOR=red][B]c[/B][/COLOR].Interior.ColorIndex = 4 Then
For Each c In Range("$K$5:$K$534")

c Nn'existe pas encore qu'il est déja utilisé (le pauvre )
Une proposition en aveugle donc a tester:

[COLOR=blue]Sub[/COLOR] ArchCEXTRUDEUSE()
j = 1
[COLOR=blue]With[/COLOR] Worksheets("EXTRUDEUSES")
    Lig = .Range("B" & Application.Rows.Count).End(xlUp).Row
    .Range("B1:J1").Copy
    .Range("B" & Lig + 3).PasteSpecial Paste:=xlPasteValues
    [COLOR=blue]For[/COLOR] i = 7 [COLOR=blue]To[/COLOR] 23 [COLOR=blue]Step[/COLOR] 2
        Worksheets("COMPTEURS").Cells(i, 2).Value = .Cells(1, j)
        j = j + 1
    [COLOR=blue]Next[/COLOR] i
[COLOR=blue]End With[/COLOR]
Range("B1:J1").ClearContents
[COLOR=blue]If[/COLOR] Range("K535") >= Range("K536") - 24 [COLOR=blue]Then[/COLOR]
    [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] Range("$K$5:$K$534")
        [COLOR=blue]If[/COLOR] c.Interior.ColorIndex = 4 [COLOR=blue]Then[/COLOR]
            c.ClearContents
            c.Interior.ColorIndex = xlNone
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] c
[COLOR=blue]End If[/COLOR]
[COLOR=blue]End Sub[/COLOR]

Cordialement:

 

[netten]

Re : compteur avec remise à 0 automatique

Voilà le fichier en question, j'ai juste essayé avec la colonne extrudeuse 4035 dans l'onglet extrudeuse, après ce ne sera que la répétition du code pour chaque feuille,...
Désolé Efgé, ça n'a pas fonctionné

Free - Envoyez vos documents

 

[netten]

Re : compteur avec remise à 0 automatique

La procédure : on rentre les données chiffrées dans les cellules de la ligne 1 des cellules B à J en jaune puis on clique sur archiver, tout le reste se fait tou seul.

 

[Efgé]

Re : compteur avec remise à 0 automatique

Re
Remplacer

Worksheets("COMPTEURS").[COLOR=red][B]Cells(i, 2).[/B][/COLOR]Value = .Cells(1, j)

Par

Worksheets("COMPTEURS").[COLOR=red][B]Cells(2, i).[/B][/COLOR]Value = .Cells(1, j)

Cordialement

 

[Efgé]

Re : compteur avec remise à 0 automatique

Re
Je ne peux aller sur Free.
Je passe la main.
Cordialement

 

[netten]

Re : compteur avec remise à 0 automatique

Si je remplace la totalité de mon code par celui que tu me propose, mes données ne s'archivent plus, et l'effacement des cellulles colorées en vert n'est pas effectif. tu as essayé sur mon fchier ?

 

[Efgé]

Re : compteur avec remise à 0 automatique

Re

tu as essayé sur mon fchier ?

Tu as lu mes derniers posts ?
Cordialement

 

[netten]

Re : compteur avec remise à 0 automatique

erreur de clique, au moment ou j'ai rédigé, je n'ai pas vu ton post ^^

 

[Efgé]

Re : compteur avec remise à 0 automatique

Re
Dernière tentative,en touhant moins le code de départ.

[COLOR=blue]Sub[/COLOR] ArchCEXTRUDEUSE2()
j = 2
[COLOR=blue]With[/COLOR] Sheets("EXTRUDEUSES")
    .Range("B1:J1").Copy
    lig = 1
    [COLOR=blue]Do While[/COLOR] .Range("B4").Cells(lig, 1) <> ""
        lig = lig + 1
    [COLOR=blue]Loop[/COLOR]
    .Range("B" & lig + 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    [COLOR=blue]For[/COLOR] i = 7 [COLOR=blue]To[/COLOR] 23 [COLOR=blue]Step[/COLOR] 2
        Worksheets("COMPTEURS").Cells(2, i).Value = .Cells(1, j)
        j = j + 1
    [COLOR=blue]Next[/COLOR] i
[COLOR=blue]End With[/COLOR]
Range("B1:J1").ClearContents
[COLOR=blue]If[/COLOR] Range("K535") >= Range("K536") - 24 [COLOR=blue]Then[/COLOR][COLOR=green] 'Cette condition est à vérifier[/COLOR]
    [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] Range("$K$5:$K$534")
        [COLOR=blue]If[/COLOR] c.Interior.ColorIndex = 4 [COLOR=blue]Then[/COLOR]
            c.ClearContents
            c.Interior.ColorIndex = xlNone
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] c
[COLOR=blue]End If[/COLOR]
[COLOR=blue]End Sub[/COLOR]

Cordialement

 

[netten]

Re : compteur avec remise à 0 automatique

J'ai essayé toutes ces formules, mais rien y faire, je ne trouve pas. Quelqu'un aurait une petite idée ?