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 SubMerci d'avance de votre aide... j'ai fait des essais mais ce n'était pas concluant...