XL 2013 Couper-coller ligne sans formulaire entre 2 tableaux structurés

A

Ananas94

XLDnaute Junior
Bonjour,

Après maintes recherches sur les forums, je ne trouve toujours pas de solution à mon problème qui est pourtant à mon avis assez simple ....
J'ai 2 tableaux : un avec des données de l'année courante et un autre avec des données de l'année dernière, qui est une archive. Je souhaite, lors d'un changement d'année, enlever les données de l'année passée qui sont dans le tableau de départ et les placer dans le tableau d'archive (tableau d'arrivée).
J'ai fait une macro (cf fichier joint), mais le résultat n'est pas du tout celui attendu et je ne comprends pas pourquoi !!

Quelqu'un pourrait m'aider s'il vous plaît ?
Merci :)
 

Pièces jointes

  • Couper_lig_essai.xlsm
    21.6 KB · Affichages: 10
Solution
job75
Si l'on veut supprimer les lignes copiées du tableau Depart on utilisera ce fichier (2) et la macro :
VB: 
Sub Archive_donnees()
Dim dest As Range
With [Arrivee].ListObject.Range.Columns(1)
    Set dest = .EntireColumn.Find("", .Cells(1), xlValues) '1ère cellule vide de destination
End With
Application.ScreenUpdating = False
With [Depart].ListObject.Range
    .Columns(2).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(2) = "=1/(YEAR(RC[-1])=YEAR(TODAY()))"
    .Columns(2) = .Columns(2).Value 'supprime les formules
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    With Intersect(.Columns(2).SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells)...
Trier par date Trier par votes
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Ananas, bonjour le forum,

Peut-être comme ça :
VB: 
Sub Archive_donnees()
Dim LO1 As ListObject, LO2 As ListObject
Dim PL1 As Range, PL2 As Range
Dim I As Integer

Set LO1 = Sheets("Depart").ListObjects("Depart")
Set PL1 = LO1.DataBodyRange
Set LO2 = Sheets("Arrivee").ListObjects("Arrivee")
Application.ScreenUpdating = False
For I = PL1.Rows.Count To 1 Step -1
    If Year(PL1.Item(I, 1)) <> Year(Date) Then
        LO2.ListRows.Add
        Set PL2 = LO2.DataBodyRange
        PL1.Rows(I).Copy PL2.Item(PL2.Rows.Count, 1)
        LO1.ListRows(I).Delete
    End If
Next I
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonjour.
Votre LO1.Range(i, 1).Rows.Delete ne va pas du tout :
Les lignes d'une seule cellule ça reste une seule cellule, et en l'absence de spécification de xlShift il risque de déplacer vers la gauche celles à sa droite. Sans compter que s'il fonctionnait ça ferait remonter le reste des lignes et que vous en louperiez une au passage suivant dans la boucle.
À votre place j'utiliserais deux tableaux dynamiques.
 
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonjour @Robert
Ma version avec les tableaux :
VB: 
Option Explicit
Sub Archive_donnees()
   Dim LOtDon As ListObject, LOtArc As ListObject, TDonn(), LDIni As Long, LDRes As Long, TArch(), LArch As Long, C As Long
   Set LOtDon = Sheets("Depart").ListObjects("Depart")
   Set LOtArc = Sheets("Arrivee").ListObjects("Arrivee")
   TDonn = LOtDon.DataBodyRange.Value
   ReDim TArch(1 To UBound(TDonn), 1 To UBound(TDonn, 2))
   For LDIni = 1 To UBound(TDonn, 1)
      If Year(TDonn(LDIni, 1)) <> Year(Date) Then
         LArch = LArch + 1
         For C = 1 To UBound(TDonn, 2): TArch(LArch, C) = TDonn(LDIni, C): Next C
      Else
         LDRes = LDRes + 1
         For C = 1 To UBound(TDonn, 2): TDonn(LDRes, C) = TDonn(LDIni, C): Next C
         End If
      Next LDIni
   If LDRes < LOtDon.ListRows.Count Then
      LOtDon.ListRows(LDRes + 1).Range.Resize(LOtDon.ListRows.Count - LDRes).Delete xlShiftUp
      If LDRes > 0 Then LOtDon.DataBodyRange.Value = TDonn
      End If
   If LArch > 0 Then
      LOtArc.ListRows.Add.Range.Resize(LArch).Value = TArch
      End If
   End Sub
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Ananas94, Robert, Bernard,

Avec le filtre avancé c'est assez simple :
VB: 
Sub Archive_donnees()
Dim F As Worksheet, dest As Range, critere As Range
With [Arrivee].ListObject.Range.Columns(1)
    Set F = .Parent
    Set dest = .EntireColumn.Find("", .Cells(1), xlValues) '1ère cellule vide de destination
End With
With [Depart].ListObject.Range
    Set critere = .Cells(2, .Columns.Count + 2)
    critere = "=YEAR(" & .Cells(2, 1).Address(0) & ")<>YEAR(TODAY())"
    .AdvancedFilter xlFilterCopy, critere(0).Resize(2), dest 'filtre avancé
End With
dest.ListObject.Resize dest.CurrentRegion 'redimensionne le tableau
dest.EntireRow.Delete 'supprime la ligne d'en-têtes copiée
critere = ""
F.Activate 'facultatif
End Sub
PS1: c'est un copier-coller, pas un couper-coller.

PS2 : j'ai mis le style de référence A1 au lieu de L1C1...

A+
 

Pièces jointes

  • Couper_lig_essai(1).xlsm
    22.1 KB · Affichages: 1
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Si l'on veut supprimer les lignes copiées du tableau Depart on utilisera ce fichier (2) et la macro :
VB: 
Sub Archive_donnees()
Dim dest As Range
With [Arrivee].ListObject.Range.Columns(1)
    Set dest = .EntireColumn.Find("", .Cells(1), xlValues) '1ère cellule vide de destination
End With
Application.ScreenUpdating = False
With [Depart].ListObject.Range
    .Columns(2).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(2) = "=1/(YEAR(RC[-1])=YEAR(TODAY()))"
    .Columns(2) = .Columns(2).Value 'supprime les formules
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    With Intersect(.Columns(2).SpecialCells(xlCellTypeConstants, 16).EntireRow, .Cells) 'constantes #DIV/0!
        .Columns(2).EntireColumn.Delete 'supprime la colonne auxiliaire
        .Copy dest 'copier-coller
        .EntireRow.Delete 'supprime les lignes
    End With
End With
dest.Parent.Activate 'facultatif
End Sub
Cette méthode est classique et très rapide grâce au tri de regroupement.
 

Pièces jointes

  • Couper_lig_essai(2).xlsm
    23 KB · Affichages: 3
Vote positif 0 Vote négatif
Solution
job75

job75

XLDnaute Barbatruc
Il est intéressant de comparer les durées d'exécution après recopie du tableau Depart sur 99 000 lignes.

Chez moi sur Win 10 Excel 2019 :

- macro du post #2 => 13 minutes

- macro du post #4 => 0,75 seconde

- macro du post #5 => 56 secondes (filtre avancé)

- macro du post #6 => 0,64 seconde.
 
Vote positif 0 Vote négatif
A

Ananas94

XLDnaute Junior
Dranreb à dit:
Bonjour.
Votre LO1.Range(i, 1).Rows.Delete ne va pas du tout :
Les lignes d'une seule cellule ça reste une seule cellule, et en l'absence de spécification de xlShift il risque de déplacer vers la gauche celles à sa droite. Sans compter que s'il fonctionnait ça ferait remonter le reste des lignes et que vous en louperiez une au passage suivant dans la boucle.
À votre place j'utiliserais deux tableaux dynamiques.
Cliquez pour agrandir...
Bonjour Dranreb,
Merci pour votre remarque, je ne savais pas en effet, et je ne comprenais pas pourquoi la première colonne était supprimée. Il n'est vraiment pas évident (et je pense que je n'ai toujours pas compris d'ailleurs) de manipuler une LIGNE d'un tableau structuré en VBA.
Merci en tout cas :)
 
Vote positif 0 Vote négatif
A

Ananas94

XLDnaute Junior
Robert à dit:
Bonjour Ananas, bonjour le forum,

Peut-être comme ça :
VB: 
Sub Archive_donnees()
Dim LO1 As ListObject, LO2 As ListObject
Dim PL1 As Range, PL2 As Range
Dim I As Integer

Set LO1 = Sheets("Depart").ListObjects("Depart")
Set PL1 = LO1.DataBodyRange
Set LO2 = Sheets("Arrivee").ListObjects("Arrivee")
Application.ScreenUpdating = False
For I = PL1.Rows.Count To 1 Step -1
    If Year(PL1.Item(I, 1)) <> Year(Date) Then
        LO2.ListRows.Add
        Set PL2 = LO2.DataBodyRange
        PL1.Rows(I).Copy PL2.Item(PL2.Rows.Count, 1)
        LO1.ListRows(I).Delete
    End If
Next I
Application.ScreenUpdating = True
End Sub
Cliquez pour agrandir...
Bonjour Robert,
Merci beaucoup pour votre réponse. Je viens de tester votre code et il fonctionne, mille mercis !
Donc si j'ai bien compris (je ne suis pas une pro du VBA..), pour désigner une ligne d'un tableau structuré (j'ai toujours du mal), on écrit : LO1.DataBodyRange.Rows(i) (en le déclarant comme une variable de type range, et i le numéro de la ligne dans le tableau).
Merci à vous :)
 
Vote positif 0 Vote négatif
A

Ananas94

XLDnaute Junior
Dranreb à dit:
Bonjour @Robert
Ma version avec les tableaux :
VB: 
Option Explicit
Sub Archive_donnees()
   Dim LOtDon As ListObject, LOtArc As ListObject, TDonn(), LDIni As Long, LDRes As Long, TArch(), LArch As Long, C As Long
   Set LOtDon = Sheets("Depart").ListObjects("Depart")
   Set LOtArc = Sheets("Arrivee").ListObjects("Arrivee")
   TDonn = LOtDon.DataBodyRange.Value
   ReDim TArch(1 To UBound(TDonn), 1 To UBound(TDonn, 2))
   For LDIni = 1 To UBound(TDonn, 1)
      If Year(TDonn(LDIni, 1)) <> Year(Date) Then
         LArch = LArch + 1
         For C = 1 To UBound(TDonn, 2): TArch(LArch, C) = TDonn(LDIni, C): Next C
      Else
         LDRes = LDRes + 1
         For C = 1 To UBound(TDonn, 2): TDonn(LDRes, C) = TDonn(LDIni, C): Next C
         End If
      Next LDIni
   If LDRes < LOtDon.ListRows.Count Then
      LOtDon.ListRows(LDRes + 1).Range.Resize(LOtDon.ListRows.Count - LDRes).Delete xlShiftUp
      If LDRes > 0 Then LOtDon.DataBodyRange.Value = TDonn
      End If
   If LArch > 0 Then
      LOtArc.ListRows.Add.Range.Resize(LArch).Value = TArch
      End If
   End Sub
Cliquez pour agrandir...
Bonjour Dranreb,

Merci beaucoup pour votre code, il fonctionne aussi super bien ; vous êtes tous trop forts décidément :)
Donc ici, si j'ai bien compris, vous créez "par-dessus" le tableau structuré un tableau dynamique (avec Ubound). Si j'ai bien compris, vous prenez en compte la possibilité que le tableau soit vide (et donc l'ajout d'une ligne).
Merci beaucoup,
Excellente journée :)

NB : Je ne parviens pas à désigner également votre post comme solution, j'ai l'impression qu'il ne peut y en avoir qu'une (ce qui n'est pas spécialement vrai ...)
 
Vote positif 0 Vote négatif
A

Ananas94

XLDnaute Junior
job75 à dit:
Bonjour Ananas94, Robert, Bernard,

Avec le filtre avancé c'est assez simple :
VB: 
Sub Archive_donnees()
Dim F As Worksheet, dest As Range, critere As Range
With [Arrivee].ListObject.Range.Columns(1)
    Set F = .Parent
    Set dest = .EntireColumn.Find("", .Cells(1), xlValues) '1ère cellule vide de destination
End With
With [Depart].ListObject.Range
    Set critere = .Cells(2, .Columns.Count + 2)
    critere = "=YEAR(" & .Cells(2, 1).Address(0) & ")<>YEAR(TODAY())"
    .AdvancedFilter xlFilterCopy, critere(0).Resize(2), dest 'filtre avancé
End With
dest.ListObject.Resize dest.CurrentRegion 'redimensionne le tableau
dest.EntireRow.Delete 'supprime la ligne d'en-têtes copiée
critere = ""
F.Activate 'facultatif
End Sub
PS1: c'est un copier-coller, pas un couper-coller.

PS2 : j'ai mis le style de référence A1 au lieu de L1C1...

A+
Cliquez pour agrandir...
Bonjour Job75,
Merci beaucoup pour votre aide, je ne connaissais pas cette possibilité pour les filtres avancés, mais c'est drôlement ingénieux, bravo. Merci, ça m'apprends pleins de trucs. Je ne parviens pas à faire fonctionner ovter code sur ma feuille, mais je ne dois pas sûrment pas tout saisir, je vais creuser. Je suis convaincue qu'il est bien ficelé.
Excellente journée :)

NB: Comme Dranreb, je n'arrive pas à désigner votre post comme solution au problème...
 
Vote positif 0 Vote négatif
A

Ananas94

XLDnaute Junior
job75 à dit:
Il est intéressant de comparer les durées d'exécution après recopie du tableau Depart sur 99 000 lignes.

Chez moi sur Win 10 Excel 2019 :

- macro du post #2 => 13 minutes

- macro du post #4 => 0,75 seconde

- macro du post #5 => 56 secondes (filtre avancé)

- macro du post #6 => 0,64 seconde.
Cliquez pour agrandir...
En effet, la dernière est très efficace. Enfin en tout cas, toutes fonctionnent, bravo et merci à tous. Vous êtes des génies !
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Ananas94 à dit:
Il n'est vraiment pas évident (et je pense que je n'ai toujours pas compris d'ailleurs) de manipuler une LIGNE d'un tableau structuré en VBA.
Cliquez pour agrandir...
Je trouve que si car elle correspond à un objet ListRow contenu dans une collection ListRows
Cet objet ListRow porte une propriété Range couvrant les cellules de la ligne représentée.
Ananas94 à dit:
Donc ici, si j'ai bien compris, vous créez "par-dessus" le tableau structuré un tableau dynamique (avec Ubound).
Cliquez pour agrandir...
Un tableau dynamique est créé en mémoire seulement. Mais il peut ensuite être affecté à la propriété Value d'un Range représentant plusieurs cellules. UBound permet juste de connaitre les dimensions maxi d'un tableau dynamique.
 
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
XL 2016 Fusionner 2 tableaux sans connaître le nombre de ligne des 2 tableaux
Réponses
12
Affichages
786
mapomme
mapomme
V
  • Question
Microsoft 365 ajout ligne entre 2 lignes, et déplace données partielle sur nouvelle ligne
Réponses
3
Affichages
477
vgendron
vgendron
S
  • Question
XL 2019 Déplacer ligne d'un tableau avec formule INDIRECT dans un autre tableau
Réponses
2
Affichages
539
Smookie
S
L
  • Résolu(e)
XL 2013 Garder espace de 1 ou 2 ligne(s) entre tableaux structurés sur une même feuille
Réponses
13
Affichages
2 K
Leguyl
L
A
  • Résolu(e)
XL 2013 Recherche de la lettre de la colonne d'une cellule
Réponses
2
Affichages
627
Ananas94
A
D
  • Résolu(e)
XL 2016 Fusionner 2 tableaux en 1 ou copier coller une ligne sur 2
Réponses
14
Affichages
2 K
chris
chris
M
  • Question
XL 2013 VBA : Remplir un tableau nommé et insérer lignes via formulaire
Réponses
1
Affichages
2 K
fanfan38
fanfan38
T
  • Résolu(e)
XL 2013 Couper-coller ligne d'un tableau structuré dans un autre tableau
2
Réponses
24
Affichages
4 K
themyse1
T
A
  • Résolu(e)
XL 2013 Ajouter des formules dans un tableau de dimensions variables
2 3 4
Réponses
48
Affichages
4 K
Ananas94
A
E
  • Question
Macro VBA Excel - copier coller données sans ouvrir les fichiers
Réponses
4
Affichages
7 K
excel girl
E

Membres actuellement en ligne

11 membres et 116 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 370
Messages
2 087 688
Membres
103 639
dernier inscrit
NIEMASAFI