Copier-Coller 2 lignes sous la sélection

Bonjour,

J'ai ce code pour ajouter 1 ligne en-dessous de la sélection en recopiant les formules et mise en forme de la ligne sélectionnée qui fonctionne parfaitement. Seulement j'aimerais l'adapter pour faire en sorte que 2 lignes soient copiées en dessous. Ci-joint un fichier pour mieux illustrer mon besoin.

Sub AjouterLigne_BoissonsConso()
  Dim Message As String, Title As String
  Dim Default As VbMsgBoxStyle
  Dim Response As VbMsgBoxResult
  Dim plage As Range
  Dim lngFirstRowInlo As Long, lngItemsCount As Long, lngRowInlo As Long
  Dim bytIndex As Byte

    Set Acell = ActiveCell
    Set lo = Sheets("Boissons_Conso").ListObjects("BoissonsConso")
    Set plage = Sheets("Boissons_Conso").ListObjects("BoissonsConso").DataBodyRange

    If Application.Intersect(Acell, plage) Is Nothing Then
        MsgBox "Veuillez sélectionner une cellule dans le tableau BoissonsConso", vbInformation
        GoTo exit_Handler
    End If

    Message = "Veuillez confirmer l'ajout de la ligne"
    Title = "Ajout d'une ligne"
    Default = vbOKCancel + vbQuestion
    Response = MsgBox(Message, Default, Title)

    If Response = vbCancel Then GoTo exit_Handler
       With lo
        bytIndex = IIf(lo.ShowHeaders, 0, 1)
        lngFirstRowInlo = .Range.Cells(1).Row
        lngItemsCount = .ListRows.Count
        lngRowInlo = Acell.Row - lngFirstRowInlo + bytIndex + 1
        If lngRowInlo > lngItemsCount Then
            .ListRows.Add
        Else
            .ListRows.Add Position:=lngRowInlo
            For Col = 2 To 11
             If .DataBodyRange(lngRowInlo - 1, Col).HasFormula Then
              .DataBodyRange(lngRowInlo - 1, Col).Copy
              .DataBodyRange(lngRowInlo, Col).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
                 SkipBlanks:=False, Transpose:=False
             End If
            Next Col
             Application.CutCopyMode = False
        End If
    End With

exit_Handler:
    Set lo = Nothing: Set Acell = Nothing
End Sub

Merci d'avance de votre aide... j'ai fait des essais mais ce n'était pas concluant...

Rechercher des sujets similaires à "copier coller lignes selection"