Insertion de ligne avec bouton sur ligne active

Bonjour,

J'ai ce code qui fonctionne parfaitement:

Sub InsererLignes()

    Dim cs As String
    cs = ActiveSheet.Name
    Dim y As Integer
    y = Application.InputBox("Entrer le # de la ligne que vous voulez ajouter", _
    Type:=1)
    If MsgBox("Êtes vous certain de vouloir ajouter la ligne " & y & " sur toutes les feuilles?", _
    vbYesNo, "Insertion de lignes sur toutes les feuilles") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    Dim r As Range
    Dim ws As Worksheet

    If y > 6 Then

             For Each ws In ThisWorkbook.Worksheets
                If ws.Name <> "TAUX DE CHANGE-FORECAST" Then
                ws.Activate
                ActiveSheet.Rows("5:5").Select
                Selection.Copy
                Rows(y).Select
                Selection.Insert Shift:=xlDown
                   Rows(y).EntireRow.Hidden = False

                 End If

             Next ws

            For Each ws In ThisWorkbook.Worksheets
            If ws.Name <> "TAUX DE CHANGE-FORECAST" Then
             ws.Activate
             ActiveSheet.Rows("5:5").Select
             Selection.Copy
             Rows(y).Select
             ActiveSheet.Paste
             Rows(y).EntireRow.Hidden = False
             ActiveSheet.Rows(y).Select
             Application.CutCopyMode = False

           End If

            Next ws

    End If

    Sheets(cs).Activate
    Application.ScreenUpdating = True
    ActiveSheet.Rows(y).Select

End Sub

J'aimerais cependant éliminer l'étape des boites de dialogues et faire en sorte que de cliquer sur le bouton insère immédiatement la ligne sur la ligne qui en ce moment sélectionnée.

Merci de votre aide,

Bonjour,

Une suggestion, voir si ça convient...

J'ai enlevé quelques "select" inutiles.

Sub InsererLignes()

Dim cs As String
   cs = ActiveSheet.Name
   Dim y As Integer
   '''    y = Application.InputBox("Entrer le # de la ligne que vous voulez ajouter", _
    Type:=1)
   '''    If MsgBox("Êtes vous certain de vouloir ajouter la ligne " & y & " sur toutes les feuilles?", _
    vbYesNo, "Insertion de lignes sur toutes les feuilles") = vbNo Then Exit Sub
   Application.ScreenUpdating = False
   Dim r As Range
   Dim ws As Worksheet

   y = ActiveCell.Row      ' ********* Ligne ajoutée
   If y > 6 Then

      For Each ws In ThisWorkbook.Worksheets
         If ws.Name <> "TAUX DE CHANGE-FORECAST" Then
            ws.Activate
            Rows(y).Insert Shift:=xlDown
            ActiveSheet.Rows("5:5").Copy Rows(y)
            Rows(y).EntireRow.Hidden = False
         End If
      Next ws

      For Each ws In ThisWorkbook.Worksheets
         If ws.Name <> "TAUX DE CHANGE-FORECAST" Then
            ws.Activate
            ActiveSheet.Rows("5:5").Copy Rows(y)
            Rows(y).EntireRow.Hidden = False
            ActiveSheet.Rows(y).Select
            Application.CutCopyMode = False
        End If
      Next ws

   End If

   Sheets(cs).Activate
   Application.ScreenUpdating = True
   ActiveSheet.Rows(y).Select

End Sub

ric

Salut PhilippeLe,

tu m'arrêtes si je me trompe : tu veux, dans chaque feuille, sauf 'TAUX...', insérer une ligne X et y coller les valeurs de la ligne 5 de cette même feuille...

A tester...

Private Sub InsérerLigne()
'
Dim ws As Worksheet
Dim r As Range
Dim iRow%, iCol%
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
iRow = Application.InputBox("Entrer le # de la ligne que vous voulez ajouter", Type:=1)
If MsgBox("Êtes vous certain de vouloir ajouter la ligne " & y & " sur toutes les feuilles?", _
vbYesNo, "Insertion de lignes sur toutes les feuilles") = vbNo Then Exit Sub
'
If iRow > 6 Then
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "TAUX DE CHANGE-FORECAST" Then
            ws.Rows(iRow).Insert shift:=xlDown
            iCol = ws.Cells(5, Columns.Count).End(xlToLeft).Column
            ws.Range("A" & iRow).Resize(1, iCol).Value = ws.Range("A5").Resize(1, iCol).Value
        End If
    Next
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

A+

Merci à vous 2 pour votre temps.

Ric, j'ai testé ta réponse en 1er et tout fonctionne à merveille! Merci beaucoup!

Étant donné que tout fonctionne parfaitement, je n'ai pas pris le temps de tester la 2e option, mais encore une fois, merci de votre temps!