Microsoft 365 Placer un tableau VBA dans un tableau structuré Excel

[iliess]

Bonjour
Voici le code suivant qui place un tableau VBA (Arr) dans un tableau structuré (Tableau 2). Le code fonctionne très bien, mais si j'ajoute la ligne Total dans le tableau structuré Tableau2, la structure du tableau2 est mal structurée.

Sub test()
Dim Arr As Variant
Dim Sh1 As Worksheet, Sh2 As Worksheet
Set Sh1 = ThisWorkbook.Sheets("Feuil1")
Set Sh2 = ThisWorkbook.Sheets("Feuil2")
Arr = Sh1.Range("Tableau1").Value
Range("Tableau2").EntireRow.Delete
Sh2.Range("A2").Resize(UBound(Arr), 2).Value = Arr
End Sub

 

[TooFatBoy]

Bonjour,

Proposition de macro à tester :

Sub Copiage()
'
    If Range("Tableau1").ListObject.DataBodyRange Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    With Range("Tableau2")
        If Not .ListObject.DataBodyRange Is Nothing Then .Delete
        Range("Tableau1").Copy
        .Cells(1, 1).PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False

End Sub

 

[Dranreb]

Bonsoir.
J'utilise souvent une Property Let TableauRetaillé utilitaire pour ça :

Option Explicit
Sub test()
   Dim Arr() As Variant
   Dim Sh1 As Worksheet, Sh2 As Worksheet
   Set Sh1 = ThisWorkbook.Sheets("Feuil1")
   Set Sh2 = ThisWorkbook.Sheets("Feuil2")
   Arr = Sh1.Range("Tableau1").Value
   TableauRetaillé(Sh2.ListObjects("Tableau2")) = Arr
   End Sub
Property Let TableauRetaillé(ByVal LOt As ListObject, Optional ByVal LMax As Long, TVals())
   Dim Trop As Long, CMax As Long, TFml(), F As Long
   If LMax = 0 Then LMax = UBound(TVals, 1)
   Trop = LOt.ListRows.Count - LMax
   If Trop > 0 Then
      LOt.ListRows(LMax + 1).Range.Resize(Trop).Delete xlShiftUp
   ElseIf Trop < 0 Then
      LOt.ListRows(LMax + Trop).Range.Resize(-Trop).Insert xlShiftDown, xlFormatFromLeftOrAbove
      End If
   If LMax = 0 Then Exit Property
   ReDim TFml(1 To LOt.ListColumns.Count)
   For F = 1 To UBound(TFml)
      With LOt.HeaderRowRange(2, F)
         If .HasFormula Then TFml(F) = .FormulaR1C1 Else TFml(F) = Null
         End With: Next F
   LOt.HeaderRowRange.Offset(1).Resize(LMax).Value = TVals
   For F = 1 To UBound(TFml)
      If Not IsNull(TFml(F)) Then LOt.ListColumns(F).DataBodyRange.FormulaR1C1 = TFml(F)
      Next F
   End Property

Attention: elle exige un tableau, pas un Variant contenant un tableau.

 

[Dranreb]

Aïe. Ça se passe mal si le tableau est vide. Corrigé :

Property Let TableauRetaillé(ByVal LOt As ListObject, Optional ByVal LMax As Long, TVals())
   Dim Trop As Long, Manq As Long, TFml(), F As Long
   If LMax = 0 Then LMax = UBound(TVals, 1)
   Trop = LOt.ListRows.Count - LMax
   If Trop > 0 Then
      LOt.ListRows(LMax + 1).Range.Resize(Trop).Delete xlShiftUp
   ElseIf Trop < 0 Then
      With LOt.ListRows.Add.Range
         Manq = -Trop - 1
         If Manq > 0 Then .Resize(Manq).Insert xlShiftDown, xlFormatFromLeftOrAbove
         End With
      End If
   If LMax = 0 Then Exit Property
   ReDim TFml(1 To LOt.ListColumns.Count)
   For F = 1 To UBound(TFml)
      With LOt.HeaderRowRange(2, F)
         If .HasFormula Then TFml(F) = .FormulaR1C1 Else TFml(F) = Null
         End With: Next F
   LOt.HeaderRowRange.Offset(1).Resize(LMax).Value = TVals
   For F = 1 To UBound(TFml)
      If Not IsNull(TFml(F)) Then LOt.ListColumns(F).DataBodyRange.FormulaR1C1 = TFml(F)
      Next F
   End Property

 

[iliess]

Bonsoir
Merci M. @Dranreb pour votre participation et votre bonne réponse.
Au début, j'ai pensé que c'est seulement activer et désactiver cette expression du code : Sh2.ListObjects("Tableau2").ShowTotals
Votre code est bien structuré et ça marche très bien.
salutations.

 

[iliess]

Oui, j'ai constaté que si le tableau est vide, le code ne marche pas.

 

[iliess]

Merci pour la mise à jour.

 

[iliess]

Je vous exprime ma gratitude pour votre réaction rapide et précise.

 

[mapomme]

Bonsoir,

Avec le code de @TooFatBoy (que je salue ), on peut aussi tester (fonctionne même si le tableau destination est vide - ou le tableau source) :

Sub Copie()
   If Sheets("Feuil2").ListObjects("Tableau2").ListRows.Count > 0 Then Range("Tableau2").Delete xlShiftUp
   Range("Tableau1").Copy: Range("Tableau2")(1, 1).PasteSpecial xlPasteValues
End Sub

 

[TooFatBoy]

Si Tableau1 est vide, ça copie une ligne vide dans le Tableau2 qui du coup ne reste pas vide, me semble-t-il.
C'est pourquoi j'a ajouté une ligne pour tester si le Tableau1 est vide.

 

[mapomme]

Si Tableau1 est vide, ça copie une ligne vide dans le Tableau2 qui du coup ne reste pas vide, me semble-t-il.
C'est pourquoi j'a ajouté une ligne pour tester si le Tableau1 est vide.

Bien vu !

Alors on peut utiliser une procédure générique de code :

Sub TS1versTS2(TS1 As ListObject, TS2 As ListObject)
   If TS2.ListRows.Count Then TS2.DataBodyRange.Delete
   If TS1.ListRows.Count Then TS1.DataBodyRange.Copy: TS2.HeaderRowRange(2, 1).PasteSpecial xlPasteValues
End Sub

Qu'on utilisera par exemple comme ceci pour y faire appel :

TS1versTS2 Sheets("Feuil1").ListObjects("Tableau1"), Sheets("Feuil2").ListObjects("Tableau2")

 

[Dranreb]

@TooFatBoy et @mapomme Bonjour.
je n'insère une ligne que s'il y a lieu d'un insérer au moins une.
Vos solutions écrasent toujours la TotalRowRange sans redimensionner la DataBodyRange me semble-t-il.

 

[TooFatBoy]

Vos solutions écrasent toujours la TotalRowRange sans redimensionner la DataBodyRange me semble-t-il.

Pas avec Excel 2016.
(pour une fois, j'ai testé avant de poster la proposition de #2)

 

[Dranreb]

En effet, je n'avais pas testé ce cas de copier/coller. Dommage qu'on ne puisse pas faire aussi simple pour y décharger un tableau dynamique en mémoire.

 

[mapomme]

Bonjour à tous ,

Un classeur pour tester la solution de mapomme (inspirée initialement par @TooFatBoy).

• avec les boutons Vider ou Remplir, initialiser les deux tableaux
• puis avec le bouton Tableau 1 vers Tableau 2, copier tableau1 vers tableau2