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

iliess

XLDnaute Occasionnel
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.
VB:
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
1234.png
 

Pièces jointes

  • Fichier demo.xlsm
    19.9 KB · Affichages: 5
Solution
Aïe. Ça se passe mal si le tableau est vide. Corrigé :
Code:
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) =...

TooFatBoy

XLDnaute Barbatruc
Bonjour,

Proposition de macro à tester :
VB:
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
 

Pièces jointes

  • Fichier demo.xlsm
    27.2 KB · Affichages: 1
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonsoir.
J'utilise souvent une Property Let TableauRetaillé utilitaire pour ça :
VB:
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

XLDnaute Barbatruc
Aïe. Ça se passe mal si le tableau est vide. Corrigé :
Code:
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

XLDnaute Occasionnel
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.
 

mapomme

XLDnaute Barbatruc
Supporter XLD
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) :
VB:
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
 

mapomme

XLDnaute Barbatruc
Supporter XLD
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 :
VB:
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 :
VB:
TS1versTS2 Sheets("Feuil1").ListObjects("Tableau1"), Sheets("Feuil2").ListObjects("Tableau2")
 

Discussions similaires

Réponses
12
Affichages
446
Réponses
3
Affichages
280
Réponses
49
Affichages
1 K

Statistiques des forums

Discussions
314 952
Messages
2 114 695
Membres
112 217
dernier inscrit
Elouan13