Macro : Ajuster automatiquement un Tab Structuré quand ajout de données
Bonjour à tous,
J'ai besoin de votre aide sur la macro que j'ai réalisé ci-après.
Le but est de copier les données des TCD et de les coller dans chaque Tableau structuré.
Le problème est le suivant : Mon fichier actuel n'a que la base de données de Janvier et le mois prochain j'aurai en plus de celle de Janvier la base de Février. Par conséquent, j'aimerai que la macro ajuste le format du tableau structuré en fonction du nombre de ligne. Actuellement quand je lance la macro, ça colle la dernière ligne sur mon total (j'ai masqué le nom des clients)
Dans la capture ci-dessus, il me fallait une ligne en plus et ça vient me la coller sur le total... Et quand je copie les données du TCD et que je les colle manuellement en valeur dans le tableau structuré, celui-ci s'adapte et conserve mon Total tout en intégrant les données dans le tableau structuré
N'hésitez pas à me dire si ma demande est réalisable où s'il faut que je fasse autrement
Merci d'avance pour votre aide
Bonne fin de matinée,
Sub CopierDonneesPivotTablesTest3()
Dim wsPivot As Worksheet
Dim wsSynthese As Worksheet
Dim pivotTable As pivotTable
Dim tableName As ListObject
Dim plageCopie As Range
Dim derniereLigne As Long
Dim celluleDestination As Range
Dim i As Long
Dim plageFiltrée As Range
Dim dataRange As Range
Dim isEmpty As Boolean
' Définir les groupes (TCD, Tableau structuré)
Dim groupes As Variant
groupes = Array( _
Array("CA_Facturé_Jens_Röstel", "Customers_Jens_Röstel"), _
Array("CA_Facturé_Joachim_Hack", "Customers_Joachim_Hack"), _
Array("CA_Facturé_Christine_Vogl", "Customers_Christine_Vogl"), _
Array("CA_Facturé_Allemagne", "Customers_Allemagne"), _
Array("CA_Facturé_Autriche", "Customers_Autriche") _
)
' Définir les feuilles
Set wsPivot = ThisWorkbook.Sheets("Pivot Table")
Set wsSynthese = ThisWorkbook.Sheets("Synthèse_Customers")
' Boucle sur chaque groupe TCD/Tableau
Dim entry As Variant
For Each entry In groupes
' Définir le tableau croisé dynamique
On Error Resume Next
Set pivotTable = wsPivot.PivotTables(entry(0))
On Error GoTo 0
If pivotTable Is Nothing Then
MsgBox "Le tableau croisé dynamique '" & entry(0) & "' est introuvable.", vbCritical
GoTo NextEntry
End If
' Définir le tableau structuré de destination
On Error Resume Next
Set tableName = wsSynthese.ListObjects(entry(1))
On Error GoTo 0
If tableName Is Nothing Then
MsgBox "Le tableau structuré '" & entry(1) & "' est introuvable.", vbCritical
GoTo NextEntry
End If
' Définir la plage des données du TCD en commençant bien en ligne 2
With pivotTable.TableRange1
derniereLigne = .Rows.Count + .row - 1
Set plageCopie = wsPivot.Range(.Cells(2, 1), .Cells(derniereLigne, .Columns.Count))
End With
' Exclure la ligne "Total général"
Set plageFiltrée = Nothing
For i = 1 To plageCopie.Rows.Count
If LCase(Trim(plageCopie.Cells(i, 1).Value)) <> "total général" Then
If plageFiltrée Is Nothing Then
Set plageFiltrée = plageCopie.Rows(i)
Else
Set plageFiltrée = Union(plageFiltrée, plageCopie.Rows(i))
End If
End If
Next i
' Vérifier si on a bien des données à copier
If plageFiltrée Is Nothing Then
MsgBox "Aucune donnée valide à copier pour " & entry(0) & " (les totaux ont été ignorés).", vbExclamation
GoTo NextEntry
End If
' Trouver la cellule de destination (première ligne disponible)
If Not tableName.dataBodyRange Is Nothing Then
Set celluleDestination = tableName.dataBodyRange.Cells(1, 1)
Else
Set celluleDestination = tableName.Range.Cells(1, 1)
End If
' Redimensionner le tableau structuré avant collage
tableName.Resize tableName.Range.Resize(plageFiltrée.Rows.Count + 1, tableName.ListColumns.Count)
' Copier en valeurs uniquement
celluleDestination.Resize(plageFiltrée.Rows.Count, plageFiltrée.Columns.Count).Value = plageFiltrée.Value
' Supprimer les lignes vides dans le tableau structuré
On Error Resume Next
Set dataRange = tableName.dataBodyRange
On Error GoTo 0
If Not dataRange Is Nothing Then
For i = dataRange.Rows.Count To 1 Step -1
isEmpty = Application.WorksheetFunction.CountA(dataRange.Rows(i)) = 0
If isEmpty Then dataRange.Rows(i).Delete
Next i
End If
NextEntry:
Next entry
MsgBox "Données copiées, tableau structuré redimensionné et lignes vides supprimées avec succès pour tous les groupes !", vbInformation
End SubBonjour,
J'ai un peu de mal à suivre votre code, c'est pourquoi je vous met ci-après une procédure-type, avec le code commenté, pour vous aider à le reproduire.
Sub exemple()
' affectation des variables
Dim rngIni As Range, tblDest As ListObject
With ThisWorkbook.Worksheets(1)
Set rngIni = Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp))
Set tblDest = .ListObjects(1)
End With
Dim rngDestination As Range
With tblDest
' Desactivation des totaux (important)
tblDest.ShowTotals = False
' ajout d'une ligne
Set rngDestination = .ListRows.Add.Range
End With
' copie des valeurs dans la ligne ajoutee
rngDestination.Resize(rngIni.Rows.Count, rngIni.Columns.Count).Value2 = rngIni.Value2
With tblDest
' allongement du tableau
.Resize .Range.CurrentRegion
' reaffichage des totaux
.ShowTotals = True
End With
End SubLa feuille d'exemple avant et après.
Merci pour votre retour !!
Je vais essayer ce que vous proposez et reviens vers vous ;-)
Merci beaucoup pour votre aide !!
Votre code m'a bien aidé et j'ai pu adapté celui que j'avais fait avec le votre :-)
Ci-après le code final qui fonctionne parfaitement
Sub CopierDonneesPivotTablesTest3()
Dim wsPivot As Worksheet
Dim wsSynthese As Worksheet
Dim pivotTable As PivotTable
Dim tableName As ListObject
Dim plageCopie As Range
Dim derniereLigne As Long
Dim celluleDestination As Range
Dim i As Long
Dim plageFiltrée As Range
Dim dataRange As Range
Dim isEmpty As Boolean
Dim rngDestination As Range
' Définir les groupes (TCD, Tableau structuré)
Dim groupes As Variant
groupes = Array( _
Array("CA_Facturé_Jens_Röstel", "Customers_Jens_Röstel"), _
Array("CA_Facturé_Joachim_Hack", "Customers_Joachim_Hack"), _
Array("CA_Facturé_Christine_Vogl", "Customers_Christine_Vogl"), _
Array("CA_Facturé_Allemagne", "Customers_Allemagne"), _
Array("CA_Facturé_Autriche", "Customers_Autriche") _
)
' Définir les feuilles
Set wsPivot = ThisWorkbook.Sheets("Pivot Table")
Set wsSynthese = ThisWorkbook.Sheets("Synthèse_Customers")
' Boucle sur chaque groupe TCD/Tableau
Dim entry As Variant
For Each entry In groupes
' Définir le tableau croisé dynamique
On Error Resume Next
Set pivotTable = wsPivot.PivotTables(entry(0))
On Error GoTo 0
If pivotTable Is Nothing Then
MsgBox "Le tableau croisé dynamique '" & entry(0) & "' est introuvable.", vbCritical
GoTo NextEntry
End If
' Définir le tableau structuré de destination
On Error Resume Next
Set tableName = wsSynthese.ListObjects(entry(1))
On Error GoTo 0
If tableName Is Nothing Then
MsgBox "Le tableau structuré '" & entry(1) & "' est introuvable.", vbCritical
GoTo NextEntry
End If
' Définir la plage des données du TCD en commençant bien en ligne 2
With pivotTable.TableRange1
derniereLigne = .Rows.Count + .Row - 1
Set plageCopie = wsPivot.Range(.Cells(2, 1), .Cells(derniereLigne, .Columns.Count))
End With
' Exclure la ligne "Total général"
Set plageFiltrée = Nothing
For i = 1 To plageCopie.Rows.Count
If LCase(Trim(plageCopie.Cells(i, 1).Value)) <> "total général" Then
If plageFiltrée Is Nothing Then
Set plageFiltrée = plageCopie.Rows(i)
Else
Set plageFiltrée = Union(plageFiltrée, plageCopie.Rows(i))
End If
End If
Next i
' Vérifier si on a bien des données à copier
If plageFiltrée Is Nothing Then
MsgBox "Aucune donnée valide à copier pour " & entry(0) & " (les totaux ont été ignorés).", vbExclamation
GoTo NextEntry
End If
' Désactivation temporaire des totaux
tableName.ShowTotals = False
' Ajout d'une nouvelle ligne dans le tableau structuré
Set rngDestination = tableName.ListRows.Add.Range
' Copier en valeurs uniquement
rngDestination.Resize(plageFiltrée.Rows.Count, plageFiltrée.Columns.Count).Value2 = plageFiltrée.Value2
' Supprimer les lignes vides dans le tableau structuré
On Error Resume Next
Set dataRange = tableName.DataBodyRange
On Error GoTo 0
If Not dataRange Is Nothing Then
For i = dataRange.Rows.Count To 1 Step -1
isEmpty = Application.WorksheetFunction.CountA(dataRange.Rows(i)) = 0
If isEmpty Then dataRange.Rows(i).Delete
Next i
End If
' Réactivation des totaux
tableName.Resize tableName.Range.CurrentRegion
tableName.ShowTotals = True
NextEntry:
Next entry
MsgBox "Données copiées, tableau structuré redimensionné et lignes vides supprimées avec succès pour tous les groupes !", vbInformation
End SubBonne fin de matinée et encore merci !!
Parfait, félicitations !
Juste deux conseils :
Ne mettez pas de données dans les cellules immédiatement autour de votre tableau (diagonales comprises, mais surtout ligne immédiatement au-dessus et gauche/droite) car autrement l'instruction .CurrentRegion va faire buguer votre programme.
Ensuite, j'ai vu que vous aviez nommé une variable "isEmpty". Je vous conseille de la renommer car c'est un mot-clé VBA et cela risque de vous faire planter/corrompre votre projet. Vous pouvez voir d'ailleurs que la coloration syntaxique du site vous l'a colorié en vert, comme MsgBox par exemple.
Voilà, au plaisir d'aider. Bonne journée.
J'avais pas pensé à ça concernant votre deuxième conseil
Actuellement je remplace isEmpty par estVide
Merci encore !!
bonjour KévinM6, salut Saboh12617,
un TCD ou un TS à copier et coller, c'est (presque) pareil,
Sub Coller()
Dim Lignes, Colonnes, i, X, s, c
Set c = Range("tbl_1") 'la plage à copier (donc votre Tablerange1 du TCD)
'toutes les lignes à copier, donc ici dessous on peut choisir de 2 à c.rows.count-1 pour ignorer l'entete et le total
For i = 1 To c.Rows.Count
If WorksheetFunction.CountA(c.Rows(i)) > 0 Then s = s & "," & i 'toutes les lignes à copier et coller dans ce string s
Next
If Len(s) > 0 Then 'drapeau des lignes à copier et
Lignes = Application.Transpose(Split(Mid(s, 2) & ",1", ",")) 'matrice avec les lignes ç copier (avec un dummy "1" en plus
Colonnes = Array(1, 2, 3, 4, 5) 'matrices avec les colonnes à copier
X = Application.Index(c.Value, Lignes, Colonnes) 'matrice à coller avec au bout ligne 1 en trop
With Range("tbl_2").ListObject 'TS destination
.ShowTotals = False 'cacher les totaux
If .ListRows.Count Then Set c = .ListRows.Add.Range Else Set c = .InsertRowRange 'nouvelle ligne dans un TS vide ou pas
c.Resize(UBound(X) - 1, UBound(X, 2)).Value = X 'ajouter les données
.ShowTotals = True 'montrer les totaux
End With
End If
End Subon peut paramtrer cette macro pour vos TCDs et TSs
Bonjour Bart,
Je vais regarder tous ça et j'essai de faire un retour si possible aujourd'hui sinon ça sera Lundi ;-)
Merci pour ton aide !!