Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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

Jacky67

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

tchi456

XLDnaute Occasionnel
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:

Jacky67

XLDnaute Barbatruc
Re...
Il est demandé
soit toujours identique à la ligne 6
Or la ligne 6 est blanche et sans bordure
 

tchi456

XLDnaute Occasionnel
Re bonjour Jacky,

Voici le fichier un peu plus complet pour une meilleure compréhension.
J'aimerais que toute la ligne soit copiée entièrement mais sans le contenu des cellules.

Meilleures salutations,
Thierry
 

Pièces jointes

  • Test.xlsm
    23.5 KB · Affichages: 4

tchi456

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

tchi456

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

  • Test (2).xlsm
    22.1 KB · Affichages: 1

Jacky67

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

  • Test V2.xlsm
    22.2 KB · Affichages: 3

tchi456

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

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…