toniodel16
XLDnaute Nouveau
Bonjour,
Je cherche a faire une Macro pour inserer une ligne sur plusieurs feuilles,
J ai une feuille avec une liste d'articles, en excutant la macro dans cette feuille , je souhaite inserer une ligne vierge, puis inserer cette ligne au meme endroit dans 13 autres feuilles (Jan, Feb,...), recopier les formules et effacer certaine cellules.
J ai essayé de bricoler qq chose mais la macro est tres lente.
Qq un pourrait il m aider ?
Je travaille actuellement sur 2003 mais bientot je vais passer sur 2010, donc idealement la macro devrait fonctionner egalement sur 2010.
par avance Merci.
Antoine
--------------
Sub Insert2()
Application.ScreenUpdating = False
If ActiveCell.Row < 7 Then
MsgBox "You can not select a row before the first line", vbCritical, "Error"
Else
If ActiveCell.Row > Range("END").Row Then
MsgBox "You can not select a row after the last line", vbCritical, "Error"
Else
ActiveSheet.Unprotect Password:="FFF"
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
'0 = commence a copier a ref active cell
ActiveCell.Offset(-1, 0).Range("A1").Select
vv = ActiveCell.Row
Sheets("Jan").Select
ActiveSheet.Unprotect Password:="FFF"
Range("a1").Select
ActiveCell.Offset(rowOffset:=vv).Activate
ActiveCell.Rows.Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(-1, 0).Range("A1:co1").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:co2"), Type:=xlFillDefault
'Column F,G,H = a effacer
ActiveCell.Range("f2:h2").Select
Selection.ClearContents
'Column n = a effacer
ActiveCell.Range("i1:i1").Select
Selection.ClearContents
'Column P -> a effacer
ActiveCell.Range("c1:r1").Select
Selection.ClearContents
'Sheets("Feb").Select
'....
End If
End If
End Sub
Je cherche a faire une Macro pour inserer une ligne sur plusieurs feuilles,
J ai une feuille avec une liste d'articles, en excutant la macro dans cette feuille , je souhaite inserer une ligne vierge, puis inserer cette ligne au meme endroit dans 13 autres feuilles (Jan, Feb,...), recopier les formules et effacer certaine cellules.
J ai essayé de bricoler qq chose mais la macro est tres lente.
Qq un pourrait il m aider ?
Je travaille actuellement sur 2003 mais bientot je vais passer sur 2010, donc idealement la macro devrait fonctionner egalement sur 2010.
par avance Merci.
Antoine
--------------
Sub Insert2()
Application.ScreenUpdating = False
If ActiveCell.Row < 7 Then
MsgBox "You can not select a row before the first line", vbCritical, "Error"
Else
If ActiveCell.Row > Range("END").Row Then
MsgBox "You can not select a row after the last line", vbCritical, "Error"
Else
ActiveSheet.Unprotect Password:="FFF"
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
'0 = commence a copier a ref active cell
ActiveCell.Offset(-1, 0).Range("A1").Select
vv = ActiveCell.Row
Sheets("Jan").Select
ActiveSheet.Unprotect Password:="FFF"
Range("a1").Select
ActiveCell.Offset(rowOffset:=vv).Activate
ActiveCell.Rows.Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(-1, 0).Range("A1:co1").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:co2"), Type:=xlFillDefault
'Column F,G,H = a effacer
ActiveCell.Range("f2:h2").Select
Selection.ClearContents
'Column n = a effacer
ActiveCell.Range("i1:i1").Select
Selection.ClearContents
'Column P -> a effacer
ActiveCell.Range("c1:r1").Select
Selection.ClearContents
'Sheets("Feb").Select
'....
End If
End If
End Sub