pour FFO (même si ça se fait pas dans un en-tête, désolé)

Le
Sunburn
Bonjour,
tout d'abord, les autres peuvent participer. :°), ce sujet n'est pas fermé.
FFO m'avais fais une macro pour rajouter une ligne à la fin de tableaux, en
fonction de ma précédente demande. De plus, il y a un code pour réinitialiser
ces tableaux.
Est-il possible d'adapter les codes afin de l'appliquer à ce tableau
ci-joint ?
http://cjoint.com/?mdqMqAfCjA
Merci.
yann

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Offset(1, 0).Interior.ColorIndex = xlNone And
Target.Interior.ColorIndex = 36 And Cells(Target.Row, Target.Column) <> ""
Then
Formule1 = Range("D" & Target.Row + 1).Formula
Formule2 = Range("E" & Target.Row + 1).Formula
Target.EntireRow.Copy
Target.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Target.Offset(1, 0).ClearContents
Target.Offset(-1, 0).EntireRow.Copy
Target.EntireRow.PasteSpecial Paste:=xlPasteFormats
Range("D" & Target.Row + 2).Formula = Split(Range("D" & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range("D" & Target.Row + 2).Formula,
":")(1), 1, 1) & Mid(Split(Range("D" & Target.Row + 2).Formula, ":")(1), 2,
Len(Mid(Split(Range("D" & Target.Row + 2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Range("E" & Target.Row + 2).Formula = Split(Range("E" & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range("E" & Target.Row + 2).Formula,
":")(1), 1, 1) & Mid(Split(Range("E" & Target.Row + 2).Formula, ":")(1), 2,
Len(Mid(Split(Range("E" & Target.Row + 2).Formula, ":")(1), 2)) - 1) + 1 & ")"
End If
Application.CutCopyMode = False
End Sub

'nettoyage des feuilles à tableaux 60.21 et 90.31
Sub Nettoyage()
For j = 1 To Sheets.Count
If Sheets(j).Name = "60_21" Or Sheets(j).Name = "90_31" Then
Sheets(j).Activate
i = 0
Do While Range("A9").Offset(i, 0).Row < Range("D65535").End(xlUp).Row
If Range("A9").Offset(i, 0).Interior.ColorIndex = 36 Then
n = n + 1
End If
If Range("A9").Offset(i, 0).Interior.ColorIndex <> 36 Then
n = 0
End If
If n > 3 Then
Range("A9").Offset(i, 0).EntireRow.Select
Selection.Delete
i = i - 1
End If
i = i + 1
Loop
Range("A1").Activate
End If
Next
End Sub
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
FFO
Le #18035991
Salut à toi

Je suppose que l'ajout des lignes doit mettre à jour toutes les formules des
colonnes qui en possèdent pour les lignes ajoutées
Sur ma proposition dont tu fais mention seules 2 colonnes devaient être
mises à jour
Dans ton fichier joint la bagatelle de 18 colonnes sont à réactualiser
Dur dur !!!
J'ai pour celà utilisé un boucle pour alléger le code
De plus dans ma proposition ci-dessous on faisait appel à un évennement
Or dans ton fichier on utilise l'action d'un bouton
J'ai du en conséquence adapter le code

Enfin la macro nettoyage dans ma proposition ci-dessous se base sur la
couleur jaune des cellules colonne A pour fonctionner correctement
Je t'en avais parlé dans le fil correspondant et qu'il ne falait pas
modifier ce format pour un fonctionnement correct
Or dans ton fichier disparu la couleur colonne A
Bandit !!!!
Je l'ai donc adapté pour s'appuyer sur la couleur des cellules colonne B
Mais surtout n'y touches plus ou adieu les bénéfices de la macro

Sur ce lien ton fichier adapté ainsi
Pour l'ajout des lignes aprés avoir sélectionné la dernière ligne jaune du
tableau actives le bouton "Ajouter une ligne en dessous de la ligne active"
Pour le Nettoyage utilise la macro "Nettoyage"

Le classeur :

http://www.cijoint.fr/cjlink.php?file=cj200812/cijCuf9k31.xls

Les Codes :

Ajout des lignes :

Private Sub CommandButton1_Click()
If ActiveCell.Interior.ColorIndex = 36 Or ActiveCell.Offset(0,
1).Interior.ColorIndex = 36 Then
If ActiveCell.Offset(1, 1).Interior.ColorIndex = xlNone Then
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.Offset(1, 0).ClearContents
ActiveCell.Offset(-1, 0).EntireRow.Copy
ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteFormats
Lettre = "B/C/D/E/F/G/H/I/K/L/M/N/O/P/Q/T"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
Range(Colonne & ActiveCell.Row + 2).Formula = Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Next
Range("S" & ActiveCell.Row + 2).Formula = Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(1), 2)) - 4) + 1 & ")+S8"
Range("R" & ActiveCell.Row + 2).Formula = Mid(Range("R" & ActiveCell.Row +
2).Formula, 1, 2) & Mid(Range("R" & ActiveCell.Row + 2).Formula, 3) + 1
End If
End If
End Sub

Nettoyage:

For j = 1 To Sheets.Count
If Sheets(j).Name = "60_21" Or Sheets(j).Name = "80_31" Then
Sheets(j).Activate
i = 0
Do While Range("A9").Offset(i, 0).Row < Range("A65535").End(xlUp).Row
If Range("A9").Offset(i, 1).Interior.ColorIndex = 36 Then
n = n + 1
End If
If Range("A9").Offset(i, 1).Interior.ColorIndex <> 36 Then
n = 0
End If
If n > 3 Then
Range("A9").Offset(i, 0).EntireRow.Select
Selection.Delete
i = i - 1
End If
i = i + 1
Loop
Range("A1").Activate
End If
Next


Fais des essais et dis moi !!!
Sunburn
Le #18041721
salut FFO,
bon et bien, tout d'abord je te remercie encore de te pencher sur mon
probleme.
par contre, j'ai oublié de te préciser, qu'en fait, le bouton, c'est ce que
j'ai actuellement, et que je voulais le supprimer, donc j'ai besoin de ton
aide pour automatiser cette tache, dès qu'on est sur la dernière ligne.
pour les colonnes, oui je sais, 18 ça pas du etre facile.
Donc un évènement au lieu du bouton m'irait à ravir.
pour les couleurs, je n'y touche plus, t'inquiète ....
pour le bouton "nettoyage", une précision de la page, car je voudrais et un
bouton pour le faire à la mano si nécessaire, et aussi dans mon code plus
complexe de suppression globale.

Précision :
ce tableau est un autre tableau que les tableaux pour lesquels tu m'avais
fais le travail de la macro. Je te rassure en te précisant que je les
utilise, et que c'est nikel. C'est pour cela que j'ai voulu automatiser ce
tableau..... Le bonheur entraine le bonheur !!!!

Merci beaucoup de ton aide.

YANN

"FFO" a écrit :

Salut à toi

Je suppose que l'ajout des lignes doit mettre à jour toutes les formules des
colonnes qui en possèdent pour les lignes ajoutées
Sur ma proposition dont tu fais mention seules 2 colonnes devaient être
mises à jour
Dans ton fichier joint la bagatelle de 18 colonnes sont à réactualiser
Dur dur !!!
J'ai pour celà utilisé un boucle pour alléger le code
De plus dans ma proposition ci-dessous on faisait appel à un évennement
Or dans ton fichier on utilise l'action d'un bouton
J'ai du en conséquence adapter le code

Enfin la macro nettoyage dans ma proposition ci-dessous se base sur la
couleur jaune des cellules colonne A pour fonctionner correctement
Je t'en avais parlé dans le fil correspondant et qu'il ne falait pas
modifier ce format pour un fonctionnement correct
Or dans ton fichier disparu la couleur colonne A
Bandit !!!!
Je l'ai donc adapté pour s'appuyer sur la couleur des cellules colonne B
Mais surtout n'y touches plus ou adieu les bénéfices de la macro

Sur ce lien ton fichier adapté ainsi
Pour l'ajout des lignes aprés avoir sélectionné la dernière ligne jaune du
tableau actives le bouton "Ajouter une ligne en dessous de la ligne active"
Pour le Nettoyage utilise la macro "Nettoyage"

Le classeur :

http://www.cijoint.fr/cjlink.php?file=cj200812/cijCuf9k31.xls

Les Codes :

Ajout des lignes :

Private Sub CommandButton1_Click()
If ActiveCell.Interior.ColorIndex = 36 Or ActiveCell.Offset(0,
1).Interior.ColorIndex = 36 Then
If ActiveCell.Offset(1, 1).Interior.ColorIndex = xlNone Then
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
ActiveCell.Offset(1, 0).ClearContents
ActiveCell.Offset(-1, 0).EntireRow.Copy
ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteFormats
Lettre = "B/C/D/E/F/G/H/I/K/L/M/N/O/P/Q/T"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
Range(Colonne & ActiveCell.Row + 2).Formula = Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne &
ActiveCell.Row + 2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Next
Range("S" & ActiveCell.Row + 2).Formula = Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range("S" & ActiveCell.Row +
2).Formula, ":")(1), 2)) - 4) + 1 & ")+S8"
Range("R" & ActiveCell.Row + 2).Formula = Mid(Range("R" & ActiveCell.Row +
2).Formula, 1, 2) & Mid(Range("R" & ActiveCell.Row + 2).Formula, 3) + 1
End If
End If
End Sub

Nettoyage:

For j = 1 To Sheets.Count
If Sheets(j).Name = "60_21" Or Sheets(j).Name = "80_31" Then
Sheets(j).Activate
i = 0
Do While Range("A9").Offset(i, 0).Row < Range("A65535").End(xlUp).Row
If Range("A9").Offset(i, 1).Interior.ColorIndex = 36 Then
n = n + 1
End If
If Range("A9").Offset(i, 1).Interior.ColorIndex <> 36 Then
n = 0
End If
If n > 3 Then
Range("A9").Offset(i, 0).EntireRow.Select
Selection.Delete
i = i - 1
End If
i = i + 1
Loop
Range("A1").Activate
End If
Next


Fais des essais et dis moi !!!


FFO
Le #18044421
Rebonjour à toi
Cà sera une caisse de champagne pour ton oubli !!!!!
Ci-joint ton fichier corrigé avec l'option évennement
Pour le bouton "Nettoyage" j'ai cru comprendre que tu te débrouillais tout
seul
Fais moi signe dans les cas contraire
Voilà ton fichier :

http://www.cijoint.fr/cjlink.php?file=cj200812/cij07WbbdA.xls

Fais des essais et tiens moi informé !!!
Sunburn
Le #18044971
rebonjour,.....
oui, je sais que ma tête me perdra.....
Mais bon, j'écris juste pour te demander de mettre le bon fichier en lien
s'il te plait, car là, c'est mon fichier d'origine à moi ......
:))))
Merci beaucoup.
YANN

"FFO" a écrit :

Rebonjour à toi
Cà sera une caisse de champagne pour ton oubli !!!!!
Ci-joint ton fichier corrigé avec l'option évennement
Pour le bouton "Nettoyage" j'ai cru comprendre que tu te débrouillais tout
seul
Fais moi signe dans les cas contraire
Voilà ton fichier :

http://www.cijoint.fr/cjlink.php?file=cj200812/cij07WbbdA.xls

Fais des essais et tiens moi informé !!!



FFO
Le #18044951
Rebonjours à toi
C'est bien ton fichier d'origine modifié par mes soins avec un code
évennementiel
Je viens de le rapatrier et vérifié

Je crois que tu as besoin de vacances n'est il pas !!!!

Donnes moi des nouvelles !!!!
Sunburn
Le #18045101
rebonjour,
ouais, je crosi que les vacances sont nécessaires :
je l'ouvre, j'active les macros, je met "ne pas mettre les liasons à jour"
et là, quand je descend sur la dernière ligne, et ben rien, et j'ai pas le
bouton "nettoyage", j'ai toujours mon bouton et le champs de texte en
rouge.....
J'capte rien, dsl, mais tu as koi toi, moi j'ai ça qui m'arrive de cjoint :
http://cjoint.com/?meodJNt8TB

Mereci.
YANN

"FFO" a écrit :

Rebonjours à toi
C'est bien ton fichier d'origine modifié par mes soins avec un code
évennementiel
Je viens de le rapatrier et vérifié

Je crois que tu as besoin de vacances n'est il pas !!!!

Donnes moi des nouvelles !!!!



FFO
Le #18045081
Rebonjour à toi

As tu bien lu mes explications concernant ce fichier et mes dernières
corrections !!!!!

mes propos :

"Ci-joint ton fichier corrigé avec l'option évennement
Pour le bouton "Nettoyage" j'ai cru comprendre que tu te débrouillais tout
seul
Fais moi signe dans les cas contraire"


Je ne vois pas pourquoi tu attentais un bouton de ma part car pour moi c'est
toi qui t'en occupais
Maintenant si tu le souhaites je peux faire
Il faut que tu me dises où exactement

Parcontre l'ajout des lignes lui fonctionne
As tu essayé ???

Merci pour tes réponses
Sunburn
Le #18045451
Excuses-moi !!!
Milles excuses ..............
:'((
je suis confu.
pour tester, j'avais juste selectionné une cellule de la ligne, pas saisi
dedans !!!!
Quel boufon que je suis !!!!
pour le bouton, pas de soucis, je vais le créer, ça je maitrise (enfin, si
je retrouve toutes les facultés de mon cerveau)

Ah là là, que je suis fatigué je crois !!!

Merci à toi et merci de ta patience, qui à mon égard est nécessaire
aujourd'hui.

YANN
:°)

"FFO" a écrit :

Rebonjour à toi

As tu bien lu mes explications concernant ce fichier et mes dernières
corrections !!!!!

mes propos :

"Ci-joint ton fichier corrigé avec l'option évennement
Pour le bouton "Nettoyage" j'ai cru comprendre que tu te débrouillais tout
seul
Fais moi signe dans les cas contraire"


Je ne vois pas pourquoi tu attentais un bouton de ma part car pour moi c'est
toi qui t'en occupais
Maintenant si tu le souhaites je peux faire
Il faut que tu me dises où exactement

Parcontre l'ajout des lignes lui fonctionne
As tu essayé ???

Merci pour tes réponses



Sunburn
Le #18045441
re,re
par contre, je viens de tester le "nettoyage". en fait, il me faut au moins
les 12 premières lignes, et non les 3 comme les tableaux précédents.
Désolé de ne pas t'avoir précisé cela avant.....

Bon, je réfléchis, mais je pense qu'il n'y a pas autre chose que je souhaite.

Je viens de faire le nettoyer, et la formule de la colonne R plante, car
c'est une formule qui n'inclut pas de somme,mais la valeur de la dernière
ligne de la colonne R (si ma mémoire est bonne).
Merci pour tout, je crois que là, c'ets ma dernière demande. (Jean Pierre,
que je remplace par FFO).

YANN

"FFO" a écrit :

Rebonjour à toi

As tu bien lu mes explications concernant ce fichier et mes dernières
corrections !!!!!

mes propos :

"Ci-joint ton fichier corrigé avec l'option évennement
Pour le bouton "Nettoyage" j'ai cru comprendre que tu te débrouillais tout
seul
Fais moi signe dans les cas contraire"


Je ne vois pas pourquoi tu attentais un bouton de ma part car pour moi c'est
toi qui t'en occupais
Maintenant si tu le souhaites je peux faire
Il faut que tu me dises où exactement

Parcontre l'ajout des lignes lui fonctionne
As tu essayé ???

Merci pour tes réponses



FFO
Le #18046401
Rebonjour à toi

Bon compte tenu de l'ampleur du projet qui de plus si je comprends bien
touche à sa fin tu es tout escusé

Pour cette petite ultime correction le nombre de lignes à conserver est
déterminé par la ligne :

If n > 3 Then

que tu dois mettre pour 12 lignes ainsi :

If n > 12 Then

Pour la formule de la colonne R j'ai rajouté au code cette ligne :

Range("R" & ActiveCell.Row).Formula = "=R" & ActiveCell.Row - 1

Ce qui donne au final ceci :

For j = 1 To Sheets.Count
If Sheets(j).Name = "60_21" Or Sheets(j).Name = "80_31" Then
Sheets(j).Activate
i = 0
Do While Range("A9").Offset(i, 0).Row < Range("A65535").End(xlUp).Row
If Range("A9").Offset(i, 1).Interior.ColorIndex = 36 Then
n = n + 1
End If
If Range("A9").Offset(i, 1).Interior.ColorIndex <> 36 Then
n = 0
End If
If n > 12 Then
Range("A9").Offset(i, 0).EntireRow.Select
Selection.Delete
Range("R" & ActiveCell.Row).Formula = "=R" & ActiveCell.Row - 1
i = i - 1
End If
i = i + 1
Loop
Range("A1").Activate
End If
Celà devrait convenir

Sur ce lien peut être la dernière mouture :

http://www.cijoint.fr/cjlink.php?file=cj200812/cijh3snRlp.xls

Fais des essais et dis moi !!!
Publicité
Poster une réponse
Anonyme