lignes auto - FFO

Le
Sunburn
Bonjour,
je reviens concernant mon tableau avec ajout de lignes auto.
Puis-je te demander d'avoir la bontée de regarder ce nouveau tableau ?? J'y
ai ajouté des colonnes, et je ne sais pa strop comment modifier ta macro sans
tout casser
PS : dans la ligne "TOTAL", il n'y a plus que des sommes des lignes au-dessus.
Merci beaucoup etr d'avance.
YANN
http://cjoint.com/?mrrMLKYxwR
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Sunburn
Le #18164731
j'ai modifié comme ça, je sais pas si c'est OK :
----
Private Sub CommandButton1_Click()
Tableau_80_31
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Interior.ColorIndex = 36 And Target.Offset(1,
0).Interior.ColorIndex = xlNone And Cells(Target.Row, Target.Column) <> ""
Then
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
Lettre =
"B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/AA/AB/AC/AD/AE/AF/AG/AH"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Next
End If
Application.CutCopyMode = False
End Sub
-----
Sunburn
Le #18164791
alors, en testant, ça a l'air de marché, sauf que ça plante à partir de la
colonne AA.
c'est ptèt les 2 lettres qu'il aime pas.
Merci.
YANN

"Sunburn" a écrit :

j'ai modifié comme ça, je sais pas si c'est OK :
----
Private Sub CommandButton1_Click()
Tableau_80_31
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Interior.ColorIndex = 36 And Target.Offset(1,
0).Interior.ColorIndex = xlNone And Cells(Target.Row, Target.Column) <> ""
Then
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
Lettre =
"B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/AA/AB/AC/AD/AE/AF/AG/AH"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Next
End If
Application.CutCopyMode = False
End Sub
-----



Jacky
Le #18165011
> alors, en testant, ça a l'air de marché, sauf que ça plante....


Ca alors , l'air mais pas la chanson !
;o)))

--
Salutations
JJ


"Sunburn" news:
alors, en testant, ça a l'air de marché, sauf que ça plante à partir de la
colonne AA.
c'est ptèt les 2 lettres qu'il aime pas.
Merci.
YANN

"Sunburn" a écrit :

j'ai modifié comme ça, je sais pas si c'est OK :
----
Private Sub CommandButton1_Click()
Tableau_80_31
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Interior.ColorIndex = 36 And Target.Offset(1,
0).Interior.ColorIndex = xlNone And Cells(Target.Row, Target.Column) <>
""
Then
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
Lettre >> "B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/AA/AB/AC/AD/AE/AF/AG/AH"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne &
Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Next
End If
Application.CutCopyMode = False
End Sub
-----





FFO
Le #18165171
Salut Yann

Et oui mon code n'avait pas prévu que tu t'attaques aux colonnes à 2 lettres
Je vois que tu as de grandes ambitions

Le voici donc adapté pour la circonstance :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Interior.ColorIndex = 36 And Target.Offset(1,
0).Interior.ColorIndex = xlNone And Cells(Target.Row, Target.Column) <> ""
Then
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
Lettre =
"B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/AA/AB/AC/AD/AE/AF/AG/AH"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
If IsNumeric(Mid(Split(Range(Colonne & Target.Row + 2).Formula, ":")(1), 2))
Then
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Else
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 2) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 3, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 3)) - 1) + 1 & ")"
End If
Next
End If
Application.CutCopyMode = False
End Sub


En toute logique tu dois pouvoir l'utiliser jusqu'au bout de la feuille si
elle se termine avec la colonne "IV"
Juste à adapter la variable "Lettre" en fonction du besoin

Sur ce lien ton document corrigé ainsi

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

Fais des essais et dis moi !!!!
Sunburn
Le #18170631
Salut FFO,
alors, ok, ça rajoute une ligne sur toutes les colonnes.
bon, sur mon projet, ça rame un peu, mais sur ton fichier c'est fluide.
c'est ptèt du au fait que j'ai une macro générale qui recalcule la hauteur
de certaines lignes.

Alors, 2 choses :
** tout d'abord, une fois qu'il arrive à 19 lignes en jaune 36 dans le
tableau, les formules plantent, et la somme est B12:B212 => ce tableau peut
comporter de 12 (enfin 13 avec la ligne rajoutée) à 24 lignes (je sais pas si
on peut bloquer un nombre de lignes maxi).

** ensuite, la formule pour supprimer les lignes en trop plante : sur
l'exemple joint, ça plante tout court, sur mon fichier complet, il plante car
j'ai l'impression qu'il n'arrive pas à trouver de fin à la boucle.
Je te redonne la macro 'Tableau_80_31 , il faut peut être la modifiée elle
aussi.
Merci de ton aide, même avant Noël .....
YANN

-----
Sub Tableau_80_31() 'nettoyage du tableau 80_31
For j = 1 To Sheets.Count
If Sheets(j).Name = "80_31" Then
Sheets(j).Activate
i = 0
Do While Range("A12").Offset(i, 0).Row < Range("A65535").End(xlUp).Row
If Range("A12").Offset(i, 1).Interior.ColorIndex = 36 Then
n = n + 1
End If
If Range("A12").Offset(i, 1).Interior.ColorIndex <> 36 Then
n = 0
End If
If n > 12 Then
Range("A12").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
Next
End Sub
-----
Sunburn
Le #18170621
et oui jacky, sans les paroles, on n'est rien ..... :°)
yann

"Jacky" a écrit :

> alors, en testant, ça a l'air de marché, sauf que ça plante....
Ca alors , l'air mais pas la chanson !
;o)))

--
Salutations
JJ


FFO
Le #18171861
Rebonjour à toi

Pour ta première anomalie concernant le seuil fatidique de 19 lignes
Une petite coquille dans mon code
Je l'ai corrigé ainsi :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Interior.ColorIndex = 36 And Target.Offset(1,
0).Interior.ColorIndex = xlNone And Cells(Target.Row, Target.Column) <> ""
Then
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
Lettre =
"B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/AA/AB/AC/AD/AE/AF/AG/AH"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
If IsNumeric(Mid(Split(Range(Colonne & Target.Row + 2).Formula, ":")(1), 2,
1)) Then
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Else
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 2) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 3, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 3)) - 1) + 1 & ")"
End If
Next
End If
Application.CutCopyMode = False
End Sub


Pour le nettoyage il faut retirer du code la ligne :

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

Que j'avais mise dans ton précédent classeur pour corriger les formules de
la colonne R qui ne s'adaptaient pas

Sur ce lien ton document adapté ainsi :

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

Fais des essais et dis moi !!!!
Sunburn
Le #18172931
resalut,
magnifique, tu es vraiment trop génial .....
ça fonctionne, meme sur mon classeur (ça rame mais c'est a cause de mon
autre macro).

Merci encore pour tout.
YANN

"FFO" a écrit :

Rebonjour à toi

Pour ta première anomalie concernant le seuil fatidique de 19 lignes
Une petite coquille dans mon code
Je l'ai corrigé ainsi :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Interior.ColorIndex = 36 And Target.Offset(1,
0).Interior.ColorIndex = xlNone And Cells(Target.Row, Target.Column) <> ""
Then
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
Lettre =
"B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/AA/AB/AC/AD/AE/AF/AG/AH"
For i = 0 To UBound(Split(Lettre, "/"))
Colonne = Split(Lettre, "/")(i)
If IsNumeric(Mid(Split(Range(Colonne & Target.Row + 2).Formula, ":")(1), 2,
1)) Then
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 1) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 2)) - 1) + 1 & ")"
Else
Range(Colonne & Target.Row + 2).Formula = Split(Range(Colonne & Target.Row +
2).Formula, ":")(0) & ":" & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 1, 2) & Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 3, Len(Mid(Split(Range(Colonne & Target.Row +
2).Formula, ":")(1), 3)) - 1) + 1 & ")"
End If
Next
End If
Application.CutCopyMode = False
End Sub


Pour le nettoyage il faut retirer du code la ligne :

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

Que j'avais mise dans ton précédent classeur pour corriger les formules de
la colonne R qui ne s'adaptaient pas

Sur ce lien ton document adapté ainsi :

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

Fais des essais et dis moi !!!!



Publicité
Poster une réponse
Anonyme