Bonjour, ça fait quelques jours que je cherchais un code VBA qui pourrait m'aider à insérer des lignes à l'aide d'un bouton tt en conservant les formules des lignes précédentes. J'ai réussi à trouver ce code générique sauf qu'il prend beaucoup de temps pour s'exécuter, je pense car j'ai déjà plusieurs formules dans mon fichier. J'aimerais savoir à travers vous s'il y en a un moyen pour l'optimiser ?ou s'il y une autre méthode pour faire ceci!Merci d'avance pour votre aide.
VB:
Sub InsererLignesCopierFormules()
'Macro insère ligne(s) en-dessous de la (ou des) cellule(s) choisie(s) et copie les formules uniquement
Dim NbLignes As Integer
Dim NbLignes_a As Integer
Dim SelCol As Integer
Application.ScreenUpdating = False
NbLignes = Selection.Rows.count 'Nombre de lignes dans la sélection
NbLignes_a = NbLignes
SelCol = Selection.Cells(1, 1).Column
If NbLignes > 1 Then
'On choisit la 1re ligne entière de la sélection
Selection.Cells(1, 1).EntireRow.Select
'On redimensionne du nombre de lignes choisies et on se place une ligne en dessous (.Rows(NbLignes_a + 1) )
'On redimensionne encore pour insérer le bon nombre de lignes
Selection.Resize(rowsize:=NbLignes_a).Rows(NbLignes_a + 1).EntireRow. _
Resize(rowsize:=NbLignes).Insert Shift:=xlDown
'On décale la selection
Selection.Offset(NbLignes - 1).EntireRow.Select
'"Autofill" à partir de la dernière ligne de la sélection pour recopier valeurs, formules et formats
Selection.AutoFill Selection.Resize(rowsize:=NbLignes + 1), xlFillDefault
On Error Resume Next
'On efface les constantes sous la dernière ligne de la sélection
Selection.Offset(1).Resize(NbLignes).EntireRow.SpecialCells(xlConstants).ClearContents
Else ' une seule ligne choisie
NbLignes_a = 2
ActiveCell.EntireRow.Select
Selection.Resize(rowsize:=NbLignes_a).Rows(NbLignes_a).EntireRow. _
Resize(rowsize:=NbLignes).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize(rowsize:=NbLignes + 1), xlFillDefault
On Error Resume Next
Selection.Offset(1).Resize(NbLignes).EntireRow.SpecialCells(xlConstants).ClearContents
End If
Cells(Selection.Row + 1, SelCol).Select 'pour se replacer
Application.ScreenUpdating = True
End Sub
