XL 2010 VBA - Bouton insérer une ligne au format identique à la ligne 6

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

tchi456

XLDnaute Occasionnel
Bonjour,

J'ai ce code pour pouvoir insérer une ligne au dessous par un bouton mais je souhaiterais adapter ce code pour que la ligne insérée soit toujours identique à la ligne 6 (même hauteur de ligne, même format, même couleur de remplissage mais sans contenu):

Sub BoutonInserer1LigneVide()
ActiveSheet.Unprotect Password:="."
Application.EnableEvents = False
ActiveCell.Offset(1, 0).EntireRow.Resize(1).Insert Shift:=xlDown
Application.EnableEvents = True
ActiveSheet.Protect Password:="."
End Sub

Avez-vous une astuce qui pourrait m'aider?

Mes meilleures salutations,

Thierry
 
Solution
J'ai encore une question en espérant ne pas abuser; j'ai les formules ci-dessous dans les cellules des colonnes L et S que je souhaite conserver et incrémenter à chaque insertion d'une nouvelle ligne identique à la ligne 9:

=SI(NB.VIDE(J7:L7);"";J7*K7*L7)
=SI(NB.VIDE(Q7:S7);"";Q7*R7*S7)

Comment puis-je adapter votre code qui fonctionne déjà super bien?

Meilleures salutations,

Thierry
Re..


Code:
Sub BoutonInserer1LigneVideIdentiqueLigne7()
    If ActiveCell.Row < 6 Then Exit Sub
    ActiveSheet.Unprotect Password:="."
    Application.EnableEvents = False
    With ActiveCell
        .Offset(1).EntireRow.Insert
        Rows(7).Copy
        .Offset(1).EntireRow.PasteSpecial Paste:=xlPasteFormats
        .Offset(1).RowHeight =...
Bonjour,

J'ai ce code pour pouvoir insérer une ligne au dessous par un bouton mais je souhaiterais adapter ce code pour que la ligne insérée soit toujours identique à la ligne 6 (même hauteur de ligne, même format, même couleur de remplissage mais sans contenu):

Sub BoutonInserer1LigneVide()
ActiveSheet.Unprotect Password:="."
Application.EnableEvents = False
ActiveCell.Offset(1, 0).EntireRow.Resize(1).Insert Shift:=xlDown
Application.EnableEvents = True
ActiveSheet.Protect Password:="."
End Sub

Avez-vous une astuce qui pourrait m'aider?

Mes meilleures salutations,

Thierry
Bonjour,
Essaye comme ceci
VB:
Sub BoutonInserer1LigneVide()
    ActiveSheet.Unprotect Password:="."
    Application.EnableEvents = False
    With ActiveCell
        .Offset(1, 0).EntireRow.Resize(1).Insert Shift:=xlDown
         Cells(6, 1).Copy: .Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
        .Offset(1, 0).RowHeight = Cells(6, 1).RowHeight
    End With
    Application.EnableEvents = True
    ActiveSheet.Protect Password:="."
End Sub
 
Bonjour Jacky67,

Merci pour votre code; il fonctionne bien malheureusement il ne copie pas la bordure et la couleur de la cellule en dessous de la cellule préalablement sélectionnée redevient blanche.

Meilleures salutations,

Thierry
 
Dernière édition:
Re bonjour Jacky,

Votre code fonctionne parfaitement bien.
J'ai ajouté un bouton supplémentaire pour pouvoir supprimer la ligne si erreur de manipulation:

VB:
Sub BoutonSupprimerLignes()
    ActiveSheet.Unprotect Password:="."
    If MsgBox("Voulez-vous supprimer ces lignes ? ", vbYesNo) = vbYes Then
    Selection.EntireRow.Delete
    End If
    ActiveSheet.Protect Password:="."
End Sub

Merci beaucoup pour votre aide et bon après-midi !
 
J'ai encore une question en espérant ne pas abuser; j'ai les formules ci-dessous dans les cellules des colonnes L et S que je souhaite conserver et incrémenter à chaque insertion d'une nouvelle ligne identique à la ligne 9:

=SI(NB.VIDE(J7:L7);"";J7*K7*L7)
=SI(NB.VIDE(Q7:S7);"";Q7*R7*S7)

Comment puis-je adapter votre code qui fonctionne déjà super bien?

VB:
Sub BoutonInserer1LigneVideIdentiqueLigne9()
    If ActiveCell.Row < 9 Then Exit Sub
    ActiveSheet.Unprotect Password:="."
    Application.EnableEvents = False
    With ActiveCell
        .Offset(1).EntireRow.Insert
        Rows(9).Copy
        .Offset(1).EntireRow.PasteSpecial Paste:=xlPasteFormats
        .Offset(1).RowHeight = Cells(9, 1).RowHeight
    End With
    Application.CutCopyMode = False
    Application.EnableEvents = True
    ActiveSheet.Protect Password:="."
End Sub

Meilleures salutations,

Thierry
 

Pièces jointes

J'ai encore une question en espérant ne pas abuser; j'ai les formules ci-dessous dans les cellules des colonnes L et S que je souhaite conserver et incrémenter à chaque insertion d'une nouvelle ligne identique à la ligne 9:

=SI(NB.VIDE(J7:L7);"";J7*K7*L7)
=SI(NB.VIDE(Q7:S7);"";Q7*R7*S7)

Comment puis-je adapter votre code qui fonctionne déjà super bien?

Meilleures salutations,

Thierry
Re..


Code:
Sub BoutonInserer1LigneVideIdentiqueLigne7()
    If ActiveCell.Row < 6 Then Exit Sub
    ActiveSheet.Unprotect Password:="."
    Application.EnableEvents = False
    With ActiveCell
        .Offset(1).EntireRow.Insert
        Rows(7).Copy
        .Offset(1).EntireRow.PasteSpecial Paste:=xlPasteFormats
        .Offset(1).RowHeight = Cells(7, 1).RowHeight
        Cells(7, "m").Copy Cells(.Row + 1, "m")
        Cells(7, "t").Copy Cells(.Row + 1, "t")
    End With
    Application.CutCopyMode = False
    Application.EnableEvents = True
    ActiveSheet.Protect Password:="."
End Sub
 

Pièces jointes

Re..


Code:
Sub BoutonInserer1LigneVideIdentiqueLigne7()
    If ActiveCell.Row < 6 Then Exit Sub
    ActiveSheet.Unprotect Password:="."
    Application.EnableEvents = False
    With ActiveCell
        .Offset(1).EntireRow.Insert
        Rows(7).Copy
        .Offset(1).EntireRow.PasteSpecial Paste:=xlPasteFormats
        .Offset(1).RowHeight = Cells(7, 1).RowHeight
        Cells(7, "m").Copy Cells(.Row + 1, "m")
        Cells(7, "t").Copy Cells(.Row + 1, "t")
    End With
    Application.CutCopyMode = False
    Application.EnableEvents = True
    ActiveSheet.Protect Password:="."
End Sub
Incroyable! C'est exactement ce qu'il me fallait !

Merci infiniment. Je vous souhaite une bonne fin de journée et vous adresse mes respectueuses salutations.

Thierry
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour