Microsoft 365 VBA Supprimer des lignes de tableau avec une sélection manuelle

Benoit84

XLDnaute Nouveau
Bonjour
Dans un tableau excel pour supprimer des lignes on sélectionne les cellules dans le tableau puis on fait bouton droit, supprimer puis supprimer ligne de tableau.
Pour des utilisateurs peu expériomenter d'excel, je voudrais créer une macro à lancer (en appuyant sur un bouton) après avoir fait la sélection des lignes.

J'ai essayé sans succès,

exemple

Dim MaPlage As Range

MaPlage = Range(ma selection manuelle en cours)
Selection.ListObject.ListRows(?).Delete

Pouvez vous m'aider ?
merci d'avance
 

Dranreb

XLDnaute Barbatruc
Bonjour.
J'utilise dans quelques classeurs des Shape "GrpInsérer" et "GrpSuppr" gérés par ce code :
VB:
Option Explicit
Private TCoupé(), Coupé As Boolean
Sub PositImages(ByVal LaFeuille As Worksheet, ByVal RngLig As Range, ByVal InsérerAprès As Boolean)
   Dim LO As ListObject, L As Long, Cas As Long, X As Double
   Set LO = LaFeuille.ListObjects(1)
   L = RngLig.Row - LO.HeaderRowRange.Row
   With LaFeuille.Shapes("GrpSuppr")
      .Visible = L > 0 And L <= LO.ListRows.Count
      If .Visible Then
         .Left = LO.ListColumns("B").Range.Offset(, 1).Left - 18: .Top = RngLig.Top
         While .TopLeftCell.Offset(, 1) <> "": .Left = .TopLeftCell.Offset(, 2).Left - 18: Wend
         End If: End With
   With LaFeuille.Shapes("GrpInsérer")
      If InsérerAprès Then L = L + 1: Set RngLig = RngLig.Offset(1)
      .Visible = L > 0 And L <= LO.ListRows.Count + 1
      If .Visible Then
         .Top = RngLig.Top - .Height / 2: .Left = 0
         .Left = .TopLeftCell.Left + .TopLeftCell.Width - .Width + 3
         Cas = 2 - (L <= LO.ListRows.Count)
      Else: Cas = 1: End If
      End With
   Application.EnableEvents = False
   LaFeuille.[Insertion].Value = "  " & Choose(Cas, "(sans modifier la liste)", _
      "… et ajouter sa couleur à la liste.", "… et insérer sa couleur dans la liste.")
   Application.EnableEvents = True
   End Sub
Sub ImageInsérer()
   Dim Cel As Range
   If Coupé Then
      Set Cel = LigneInsérée(ActiveSheet).Columns(2)
      Cel.Resize(, 12).Value = TCoupé: Coupé = False
      ÉtudeChange ActiveSheet, Cel
   Else: LigneInsérée ActiveSheet: End If
   End Sub
Function LigneInsérée(ByVal LaFeuille As Worksheet) As Range
   Dim Img As Shape, LO As ListObject, L As Long
   Set Img = LaFeuille.Shapes("GrpInsérer")
   Set LO = LaFeuille.ListObjects(1)
   If Img.Visible Then L = Img.BottomRightCell.Row - LO.HeaderRowRange.Row
   If L < 1 Or L > LO.ListRows.Count Then L = LO.ListRows.Count + 1
   Set LigneInsérée = LO.ListRows.Add(L).Range
   PositImages LaFeuille, LigneInsérée, InsérerAprès:=True
   End Function
Sub ImageSupprimer()
   Dim Img As Shape, LO As ListObject, L As Long
   Set Img = ActiveSheet.Shapes("GrpSuppr")
   Set LO = ActiveSheet.ListObjects(1)
   L = Img.TopLeftCell.Row - LO.HeaderRowRange.Row
   With LO.ListRows(L): Coupé = True: TCoupé = .Range.Columns(2).Resize(, 12).Value: .Delete: End With
   If LO.ListRows.Count = 0 Then [G4].Interior.Color = &HCACACA: Exit Sub
   Img.Visible = False
   ActiveSheet.Shapes("GrpInsérer").Visible = False
   PositImages ActiveSheet, LO.HeaderRowRange.Offset(L), InsérerAprès:=False
   End Sub
En résumé si vous avez pris soin de positionner convenablement votre petit bouton Img de suppression sur la ligne à supprimer possiblement, le numéro du ListRow à supprimer du ListObject LO est donné par Img.TopLeftCell.Row - LO.HeaderRowRange.Row
Sinon, si c'est moins sophistiqué, Selection.Row - LO.HeaderRowRange.Row devrait marcher aussi.
Remarque: les ListObject n'ont aparremment pas de méthode permettant de supprimer ni insérer plusieurs ListRow contigus. Mais je pense que dans ce cas on peut utiliser :
LO.ListRows(L).Range.Resize(n).Delete xlShiftUp
Suite à un essai je viens d'avoir la surprise de voir l'enregistreur de macro avoir engendré n fois ListRows(L).Delete ! Ce qu'on peut imiter plutôt avec une boucle bien sûr.
 

Pièces jointes

  • InsérCoulCls.png
    InsérCoulCls.png
    1.2 KB · Affichages: 18
  • SupprB20².png
    SupprB20².png
    900 bytes · Affichages: 13
Dernière édition:

Hasco

XLDnaute Barbatruc
Repose en paix
Bonjour,

Avec ce que je comprends de votre question :

VB:
Sub RemoveListRows()
    Dim sel As Range, lo As ListObject
    Set lo = ThisWorkbook.Sheets("Feuil1").ListObjects(1)
    Set sel = Intersect(lo.DataBodyRange, Selection.EntireRow)
    If Not sel Is Nothing Then sel.Delete xlShiftUp
End Sub
 

Pièces jointes

  • Benoît84.xlsm
    27.9 KB · Affichages: 15
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @Benoit84 et aux autres :),

Un autre essai qui gère aussi les sélections multiples (plusieurs cellules sélectionnées non contigües au sein de la même ligne)
  • Sélectionner des cellules dans et/ou en dehors du tableau structuré
  • inutile de sélectionner une ligne entière du tableau (au moins une cellule de la ligne suffit)
  • cliquer sur le bouton hop!
Le code est dans le module de la feuille "Feuil1"
VB:
Sub SupprLigne()
Dim x As Range, y As Range, z As Range

Set x = Intersect(Me.ListObjects(1).DataBodyRange, Selection)
If x Is Nothing Then Exit Sub
For Each y In x
   If z Is Nothing Then
      Set z = Intersect(Rows(y.Row), Me.ListObjects(1).DataBodyRange)
   Else
      Set z = Union(z, Intersect(Rows(y.Row), Me.ListObjects(1).DataBodyRange))
   End If
Next y
If Not z Is Nothing Then z.Delete shift:=xlShiftUp: Me.Shapes(Application.Caller).TopLeftCell.Select
End Sub
 

Pièces jointes

  • Benoit84- supprimer lignes- v1.xlsm
    19.5 KB · Affichages: 15
Dernière édition:

Hasco

XLDnaute Barbatruc
Repose en paix
Bonjour @mapomme :)

Ou me trompe-je ou il me semble que
VB:
Intersect(lo.DataBodyRange, Selection)
sel.Delete xlShiftUp
Gère les multiselections

Peut-être à rajouté : EntireRow à Selection dans Intersect(lo.DataBodyRange, Selection)

Cordialement

[Edit] je viens de corriger dans le fichier du post #4
 
Dernière édition:

Benoit84

XLDnaute Nouveau
Bonjour à vous,
Merci de vos différentes solutions, c'est exactement ce qu'il fallait.
J'ai eu un peu de mal à l'adapter dans mon tableau, il ne marchait pas car je n'avais pas mit le code dans la feuille du tableau mais dans un module.
Tout fonctionne, je vous remercie pour votre aide ;)

bonne journée
Cordialement
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 910
Membres
101 837
dernier inscrit
Ugo