Formule VBA pour rajouter les 4 dernières lignes avec leur mise en forme

Bonjour à tous,
j'ai besoin de votre aide pour ajouter les 4 même dernières lignes à suite de mon tableau avec leur mise en forme.
Ci-joint mon fichier.
Bonne journée

Je viens de réussir avec le code :

Si qql un a une idée pour l'améliorer ?

Sub Inserer_les_4_dernieres_lignes_a_la_suite_de_mon_tableau()
'

' Ici nous allons tout afficher
On Error Resume Next
Worksheets("Suivi Dossier").ShowAllData
On Error GoTo 0
Sheets("Suivi Dossier").Select
Selection.End(xlToLeft).Select

'--Ici nous allons insérer 1er ligne

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.ListObject.ListRows.Add AlwaysInsert:=False
    Selection.End(xlDown).Offset(-4, 0).Select
'
    ActiveCell.EntireRow.Select
   Application.CutCopyMode = False
    Selection.Copy

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
ActiveSheet.Paste

'--Ici nous allons insérer 2eme ligne

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.ListObject.ListRows.Add AlwaysInsert:=False
    Selection.End(xlDown).Offset(-4, 0).Select
'
    ActiveCell.EntireRow.Select
   Application.CutCopyMode = False
    Selection.Copy

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
ActiveSheet.Paste

'--Ici nous allons insérer 3eme ligne

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.ListObject.ListRows.Add AlwaysInsert:=False
    Selection.End(xlDown).Offset(-4, 0).Select
'
    ActiveCell.EntireRow.Select
   Application.CutCopyMode = False
    Selection.Copy

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
ActiveSheet.Paste

'--Ici nous allons insérer 4eme ligne

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.ListObject.ListRows.Add AlwaysInsert:=False
    Selection.End(xlDown).Offset(-4, 0).Select
'
    ActiveCell.EntireRow.Select
   Application.CutCopyMode = False
    Selection.Copy

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
ActiveSheet.Paste

Range("Tableau2[[#Headers],[Localisation]]").Select
Selection.End(xlDown).Select
ActiveCell.Select

Application.CutCopyMode = False  

End Sub

Bonjour

J'ai renommé le tableau Suivi_Dos (on ne garde pas les noms par défaut, ni pour les classeurs, ne pour les onglets, ni pour les tableaux structurés...)

Sub Inserer_les_4_dernieres_lignes_a_la_suite_de_mon_tableau()
    With Range("Suivi_Dos").ListObject
        Der = .ListRows.Count
        If Der >= 4 Then
            Cdeb = .ListColumns(1).Range.Column
            CFin = Cdeb + .ListColumns.Count - 1
            Ldeb = Der - 3 + .Range.Row
            Lfin = Der + .Range.Row
            With .Parent
                .Range(Cells(Ldeb, Cdeb), Cells(Lfin, CFin)).Copy Destination:=.Cells(Lfin + 1, Cdeb)
            End With
        End If
    End With
End Sub

A priori tu n'as plus 2007 : corrige ton profil. Merci

Bonjour 78chris,

Merci pour ton aide, question est-ce possible de garder l'encadrement des 4 lignes avec le contour en epais noir.

Merci

RE

J'ai modifié le style du tableau et ajouté du code pour tracer un trait sous les 4ème lignes des groupes de 4.
Mais Excel ne le trace que si un autre groupe suit.

J'ai également nettoyer les MFC qui me semblaient inutiles

bonjour le fil,

en utilisant le TS, ceci suffit et puis une MFC ...

Sub Inserer_les_4_dernieres_lignes_a_la_suite_de_mon_tableau()
     With Range("Suivi_Dos").ListObject
          der = .ListRows.Count
          If der >= 4 Then .ListRows(der - 3).Range.Resize(4).Copy .ListRows.Add.Range
     End With
End Sub

Merci à vous deux cela fonctionne parfaitement

Bonjour à tous,

Mon p'tit code :

Sub Copier4Lignes()
With Sheets("Suivi Dossier").Range("a1").ListObject
   If .ListRows.Count < 4 Then MsgBox "il y a moins de 4 lignes -> Echec", vbExclamation: Exit Sub
   .Resize .Range.Resize(.Range.Rows.Count + 4)
   .ListRows(.ListRows.Count - 7).Range.Resize(4).Copy .ListRows(.ListRows.Count - 3).Range.Resize(4)
   .ListRows(.ListRows.Count - 3).Range.Resize(4).BorderAround Color:=vbBlack, Weight:=xlThick
End With
End Sub

RE

Merci à BsAlv : je ne connaissais pas .ListRows.Add.Range qui résout le problème de la MFC qui se pose si on insère en-dessous du tableau et que j'avais du contourner.

Mais elle n'est même pas nécessaire avec cette méthode : la ligne existante sous la 4ème ligne se propage naturellement...

BsAlv a écrit :

bonjour le fil,

en utilisant le TS, ceci suffit et puis une MFC ...

Sub Inserer_les_4_dernieres_lignes_a_la_suite_de_mon_tableau()
     With Range("Suivi_Dos").ListObject
          der = .ListRows.Count
          If der >= 4 Then .ListRows(der - 3).Range.Resize(4).Copy .ListRows.Add.Range
     End With
End Sub

Mais elle n'est même pas nécessaire avec cette méthode : la ligne existante sous la 4ème ligne se propage naturellement...

C'est alors ceci que vous voulez , sans ce"listrows.add", ...

Sub Inserer_les_4_dernieres_lignes_a_la_suite_de_mon_tableau()
     With Range("Suivi_Dos").ListObject
          der = .ListRows.Count
           If der >= 4 Then .ListRows(der - 3).Range.Resize(4).Copy .DataBodyRange.Cells(der + 1, 1)
     End With
End Sub

PS. Ces TS, ils sont des outils vraiment pratiques, mais de temps en temps, pour le moment pas ici, ils ont des comportements bizarres,

Re

Non ton code est parfait comme il l'était

J'ai juste placé manuellement une ligne sous la 4ème du tableau fourni et ton code la répercute à chaque fois sans besoin de quoi que ce soit d'autre

(j'avais aussi associé la ligne placée sous les en-têtes à la structure du TS et à une ligne car sinon il y avait des effets de bord)