lignes auto - FFO

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

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

> 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" <Sunburn@discussions.microsoft.com> a écrit dans le message de
news: 847D438A-A2BF-48EE-A4D9-59E3D4391F24@microsoft.com...

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

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 !!!!

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

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

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 !!!!

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 !!!!