XL 2016 copie de tableaux les uns sous les autres

[mdelbois]

Bonjour,

Dans le fichier en PJ, il y a plusieurs feuilles (EM, SDH, BAT et 2éme CIE). Un responsable par feuille met à jour avec les informations en sa possession.

Il y a une macro qui permet de coller les tableaux dans la feuille LIST PERS (tableau qui compile l'ensemble du personnel). La macro s'active via un "CTRL+M".

Néanmoins si j'ajoute une ligne dans le tableau EM par exemple (arrivée d'une nouvelle personne), celle-ci s'ajoute bien dans le tableau LIST PERS mais me supprime la dernière ligne (de la partie EM dans cet exemple).

Pourriez-vous m'aider car je bloque?

merci

 

[JHA]

Bonjour à tous,

Un début de piste avec power query

Après ajout ou retrait dans les feuilles (EM, SDH, BAT et 2éme CIE), clic droit dans le tableau de la feuille "fusion" et actualiser.

JHA

 

[sylvanu]

Bonjour Mdelbois, JHA,
En PJ un essai.
Quand on sélectionne la feuille LIST PERS, on efface la tableau présent et on le reconstruit en automatique. Avec :

Public DL%
Sub Worksheet_Activate()
    Dim F, NomTablo, Tablo, Taille
    Application.ScreenUpdating = False
    For Each F In Worksheets
        If F.Name = "LIST PERS" Then        ' Si List Pers on supprime tableau
            NomTablo = Sheets(F.Name).ListObjects(1)
            Tablo = Sheets(F.Name).ListObjects(NomTablo).DataBodyRange
            Taille = UBound(Tablo)
            Range("A" & Taille + 6) = "x"   ' On prépare la dernière ligne pour le tableau suivant
            Rows("7:" & Taille + 5).Delete Shift:=xlUp
            DL = 7
        Else                                ' Sinon on transfère le tableau de la page considérée
            NomTablo = Sheets(F.Name).ListObjects(1)
            Sheets(F.Name).Range(NomTablo).Copy
            Range("A" & DL).Select
            ActiveSheet.Paste
            Tablo = Sheets("LIST PERS").ListObjects(1).DataBodyRange
            Taille = UBound(Tablo)
            DL = 6 + Taille
            Range("A" & DL) = "x"
        End If
    Next F
    DerLig = 5 + Sheets("LIST PERS").[PERS].Rows.Count
    Rows(DerLig).Delete Shift:=xlUp         ' On supprime la dernière ligne
    [A1].Select
    Application.ScreenUpdating = True
End Sub

 

[mdelbois]

Bonjour à tous,

Un début de piste avec power query

Après ajout ou retrait dans les feuilles (EM, SDH, BAT et 2éme CIE), clic droit dans le tableau de la feuille "fusion" et actualiser.

JHA

Bonjour,

C’est très bien. Par contre comment garder la mise en forme (couleur essentiellement)

Bonjour à tous,

Un début de piste avec power query

Après ajout ou retrait dans les feuilles (EM, SDH, BAT et 2éme CIE), clic droit dans le tableau de la feuille "fusion" et actualiser.

JHA

 

[mdelbois]

Bonjour Mdelbois, JHA,
En PJ un essai.
Quand on sélectionne la feuille LIST PERS, on efface la tableau présent et on le reconstruit en automatique. Avec :

Public DL%
Sub Worksheet_Activate()
    Dim F, NomTablo, Tablo, Taille
    Application.ScreenUpdating = False
    For Each F In Worksheets
        If F.Name = "LIST PERS" Then        ' Si List Pers on supprime tableau
            NomTablo = Sheets(F.Name).ListObjects(1)
            Tablo = Sheets(F.Name).ListObjects(NomTablo).DataBodyRange
            Taille = UBound(Tablo)
            Range("A" & Taille + 6) = "x"   ' On prépare la dernière ligne pour le tableau suivant
            Rows("7:" & Taille + 5).Delete Shift:=xlUp
            DL = 7
        Else                                ' Sinon on transfère le tableau de la page considérée
            NomTablo = Sheets(F.Name).ListObjects(1)
            Sheets(F.Name).Range(NomTablo).Copy
            Range("A" & DL).Select
            ActiveSheet.Paste
            Tablo = Sheets("LIST PERS").ListObjects(1).DataBodyRange
            Taille = UBound(Tablo)
            DL = 6 + Taille
            Range("A" & DL) = "x"
        End If
    Next F
    DerLig = 5 + Sheets("LIST PERS").[PERS].Rows.Count
    Rows(DerLig).Delete Shift:=xlUp         ' On supprime la dernière ligne
    [A1].Select
    Application.ScreenUpdating = True
End Sub

bonjour,

ça fonctionne. Par contre si je dois ajouter une feuille (ajout d'une compagnie) quelle ligne faut-il changer dans la macro?

 

[sylvanu]

Bonjour,
En cas d'ajout d'une feuille, il n'y a rien à faire puisque je parcourt toutes les feuilles, excepté LIST PERS.

For Each F In Worksheets        ' On parcourt toutes les feuilles'
  If F.Name = "LIST PERS" Then  ' Si la feuille s'appelle LIST PERS
                                ' On supprime le tableau
  Else                          ' Sinon'
                                ' On importe le tableau
  EndIf
Next F

 

[job75]

Bonjour mdelbois, JHA, sylvanu, le forum,

Une macro un peu différente de celle de sylvanu :

Private Sub Worksheet_Activate()
Dim lig&, col%, ncol%, h&, w As Worksheet, P As Range, rc&
Application.ScreenUpdating = False
With ListObjects(1).Range
    If .Rows.Count > 2 Then .Rows(3).Resize(.Rows.Count - 2).Delete xlUp 'RAZ
    .Rows(2).Clear 'RAZ
    lig = .Row
    col = .Column
    ncol = .Columns.Count
End With
h = 1
For Each w In Worksheets
    If w.Name <> Me.Name And w.ListObjects.Count Then
        Set P = Evaluate(w.ListObjects(1).Name) 'tableau sans les en-têtes
        If Application.CountA(P) Then 'si le tableau n'est pas vide
            rc = P.Rows.Count
            ListObjects(1).Resize Cells(lig, col).Resize(h + rc, ncol) 'redimensionne le tableau
            P.Copy Cells(lig + h, col) 'copier-coller
            h = h + rc
        End If
    End If
Next
End Sub

Toutes les feuilles autres que la 1ère feuille et contenant un tableau structuré sont copiées.

A+

 

[job75]

Fichier (2) un peu plus simple en repérant la 1ère cellule du tableau de destination :

Private Sub Worksheet_Activate()
Dim deb As Range, ncol%, h&, w As Worksheet, P As Range, rc&
Application.ScreenUpdating = False
With ListObjects(1).Range
    If .Rows.Count > 2 Then .Rows(3).Resize(.Rows.Count - 2).Delete xlUp 'RAZ
    .Rows(2).Clear 'RAZ
    Set deb = .Cells(1) '1ère cellule
    ncol = .Columns.Count
End With
h = 1
For Each w In Worksheets
    If w.Name <> Me.Name And w.ListObjects.Count Then
        Set P = Evaluate(w.ListObjects(1).Name) 'tableau sans les en-têtes
        If Application.CountA(P) Then 'si le tableau n'est pas vide
            rc = P.Rows.Count
            ListObjects(1).Resize deb.Resize(h + rc, ncol) 'redimensionne le tableau
            P.Copy deb(h + 1) 'copier-coller
            h = h + rc
        End If
    End If
Next
End Sub

 

[mdelbois]

Bonjour,
En cas d'ajout d'une feuille, il n'y a rien à faire puisque je parcourt toutes les feuilles, excepté LIST PERS.

For Each F In Worksheets        ' On parcourt toutes les feuilles'
  If F.Name = "LIST PERS" Then  ' Si la feuille s'appelle LIST PERS
                                ' On supprime le tableau
  Else                          ' Sinon'
                                ' On importe le tableau
  EndIf
Next F

Merci