Regroupement de plusieurs tableaux (VBA)

K

kam16

XLDnaute Nouveau
Bonjour,
Souhaitant regrouper plusieurs tableaux en un seul et ayant peu de connaissances en language VBA, je fais appel à votre aide. Dans le classeur excel ci-joints se trouvent 13 feuilles. Parmis ces feuilles, seulement 7 devront pour le moment être concerné par une macro de groupement.
Je souhaiterais regrouper les tableaux qui se trouvent dans les feuilles "siemens" à "kuka" en un seul qui sera générer dans la feuille GLOBAL. Les tableaux sont identiques au niveaux du nombres de colonnes et noms d'étiquettes. Seul le nombre de lignes varie. Je voudrais faire en sorte que ce tableau global s'alimente automatiquement (avec un bouton) à partir des différents tableaux lorsque dans ceux-ci on ajoute ou supprime des lignes/colonnes ou bien que l'on modifie des valeurs.
De plus, à court terme, le nombre de ligne sera bien plus grand ainsi, il faut que la macro ait une plage assez grande. Enfin, je ne sais pas si la feuille "GLOBAL" doit avoir un emplacement précis, mais je préférerais que la position actuelle des feuilles ne soit pas changée.
PS: je tacherais de comprendre la macro proposée si un jour je souhaite ajouter une nouvelle feuille et la prendre en compte dans la macro.
Je vous de remercie d'avance pour votre aide.
Cordialement
 

Pièces jointes

  • Classeur REGROUPEMENT.xlsx
    121.3 KB · Affichages: 63
Trier par date Trier par votes
H

Hieu

XLDnaute Impliqué
Re : Regroupement de plusieurs tableaux (VBA)

Salut,

Je te propose cette macro,

Code: 
Sub mlk()
Application.ScreenUpdating = False
Sheets("GLOBAL").Range("A9:AN60000").ClearContents
ligne = 1

For Each s In Worksheets
    Select Case s.Name
    Case "siemens", "cn", "abb", "telemecanique", "schneider", "kuka"
        derligne = s.Range("c2")
        For i = 1 To derligne
        For j = 0 To 39
        Sheets("GLOBAL").Range("a8").Offset(ligne, j) = s.Range("a8").Offset(i, j)
        Next j
        ligne = ligne + 1
        Next i
    End Select
Next s

End Sub

++
 

Pièces jointes

  • Classeur REGROUPEMENT_v0.xlsm
    166.5 KB · Affichages: 74
Vote positif 0 Vote négatif
Marc L

Marc L

XLDnaute Occasionnel
P'tite démonstration !


Bonjour,

comme ici il s'agit de listes / tables (cf l'aide d'Excel & l'aide VBA de [highlight]ListObject[/code]),
​
juste en respectant le modèle objet d'Excel :
​
VB: 
Sub Demo()
    Const FIN = "kuka", HDR = "A8"
    Dim oList As ListObject, W&
    Set oList = Feuil3.Range(HDR).ListObject
    With Application:  .DisplayAlerts = False:  .ScreenUpdating = False:  End With
     If oList.ListRows.Count Then
        oList.DataBodyRange.Clear
        oList.Resize oList.HeaderRowRange.Resize(2)
     End If
        oList.Parent.Activate:  oList.Range(1).Select
    For W = ActiveSheet.Index + 1 To Worksheets(FIN).Index
        With Worksheets(W).Range(HDR).ListObject
            If .ListRows.Count Then .DataBodyRange.Copy oList.InsertRowRange
        End With
    Next
     Set oList = Nothing
     With Application:  .DisplayAlerts = True:  .ScreenUpdating = True:  End With
End Sub
_______________________________________________________________________________​
Merci de cliquer sur J'aime ce post en bas à gauche de chaque message ayant aidé …
​

_______________________________________________________________________________
​
Je suis Paris, Charlie, Bruxelles, …
​
 
Dernière édition:
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
Re : Regroupement de plusieurs tableaux (VBA)

bonjour
une autre
Sub recap()
Dim Ws As Worksheet
Sheets("GLOBAL").[A9].Resize(Sheets("GLOBAL").[A65536].End(xlUp).Row - 1, 40).ClearContents

For Each Ws In Worksheets
Select Case Ws.Name
Case "siemens", "cn", "abb", "telemecanique", "schneider", "kuka"
'avec formules
' Ws.[A9].Resize(Ws.[A65536].End(xlUp).Row - 1, 40).Copy Destination:=Worksheets("Global").[A65536].End(xlUp).Offset(1, 0)
'sans formules
Ws.[A9].Resize(Ws.[A65536].End(xlUp).Row - 1, 40).Copy
Worksheets("Global").[A65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End Select
Next Ws
End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
K

kam16

XLDnaute Nouveau
Re : Regroupement de plusieurs tableaux (VBA)

Merci à tous pour vos suggestions. Néanmoins rien ne se passe dans le global, lorsque je rajoute ou supprime une colonne dans chacun des tableaux et ce, au même endroit. Il semble que la macro ne traite que les lignes. Y'a t-il un moyen de remédier à cela ?
Cordialement
 
Vote positif 0 Vote négatif
K

kam16

XLDnaute Nouveau
Re : Regroupement de plusieurs tableaux (VBA)

Meric hieu, cela marche parfaitement mais la modification au niveau des colonnes (ajout ou suppression de colonnes dans chacun des tableaux et ce, au même endroit car je suppose qu'il faut qu'ils soient toujours identiques) n'apparait pas dans le global. Ainsi, que faut-il rajouter dans la macro pour traiter aussi les colonnes ?
Cordialement
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
Re : Regroupement de plusieurs tableaux (VBA)

re
en tenant compte du nombre de lignes et colonnes dans chaque feuille
Sub recap()
Dim Ws As Worksheet, DerLi As Long, DerCol As Long
With Sheets("GLOBAL") 'il faut une ligne d'entêtes dans global
DerLi = .Cells.Find("*", [A1], , , 1, 2).Row
DerCol = .Cells.Find("*", [A1], , , 2, 2).Column
If DerLi > 8 Then .[A9].Resize(DerLi, DerCol).ClearContents
End With

For Each Ws In Worksheets
Select Case Ws.Name
Case "siemens", "cn", "abb", "telemecanique", "schneider", "kuka"
DerLi = Ws.Cells.Find("*", [A1], , , 1, 2).Row
DerCol = Ws.Cells.Find("*", [A1], , , 2, 2).Column

'avec formules
' Ws.[A9].Resize(Ws.[A65536].End(xlUp).Row - 1, 40).Copy Destination:=Worksheets("Global").[A65536].End(xlUp).Offset(1, 0)
'sans formules
Ws.[A9].Resize(DerLi, DerCol).Copy
Worksheets("Global").[A65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End Select
Next Ws
End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
K

kam16

XLDnaute Nouveau
Re : Regroupement de plusieurs tableaux (VBA)

Merci de votre réponse bebere. Mais quand je rajoute une colonne dans chacun des tableaux et que j'appuie sur le bouton la colonne n'apparait pas dans le global et au contraire un assez grand nombre de ligne apparaissent. Je dois peut-être me tromper dans la manière de faire les choses. Pourriez vous essayer directement avec le fichier Excel que j'ai fourni plus haut ? Merci bien
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif
K

kam16

XLDnaute Nouveau
Re : Regroupement de plusieurs tableaux (VBA)

Dans les tableaux de Siemens à kuka, j'ajoute une colonne, par exemple entre la colonne L12 et L13. En appuyant sur le bouton, je souhaiterais que cette colonne ajoutée apparaissent dans le global.
 
Vote positif 0 Vote négatif
B

Bebere

XLDnaute Barbatruc
Re : Regroupement de plusieurs tableaux (VBA)

la colonne ajoutée est prise en compte,dans global colonne AO
il faut changer l'entête
Sub recap()
Dim Ws As Worksheet, DerLi As Long, DerCol As Long
With Sheets("GLOBAL") 'il faut une ligne d'entêtes dans global
DerCol = Sheets("siemens").Cells.Find("*", [A1], , , 2, 2).Column
Sheets("siemens").Range("A8", Sheets("siemens").Cells(8, DerCol)).Copy Destination:=.Range("A8")'entête
DerLi = .Cells.Find("*", [A1], , , 1, 2).Row
DerCol = .Cells.Find("*", [A1], , , 2, 2).Column
If DerLi > 8 Then .[A9].Resize(DerLi, DerCol).ClearContents
End With

For Each Ws In Worksheets
Select Case Ws.Name
Case "siemens", "cn", "abb", "telemecanique", "schneider", "kuka"
DerLi = Ws.Cells.Find("*", [A1], , , 1, 2).Row
DerCol = Ws.Cells.Find("*", [A1], , , 2, 2).Column

'avec formules
' Ws.[A9].Resize(Ws.[A65536].End(xlUp).Row - 1, 40).Copy Destination:=Worksheets("Global").[A65536].End(xlUp).Offset(1, 0)
'sans formules
Ws.[A9].Resize(DerLi, DerCol).Copy
Worksheets("Global").[A65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End Select
Next Ws
End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
K

kam16

XLDnaute Nouveau
Re : Regroupement de plusieurs tableaux (VBA)

Merci Bebere, cela fonctionne la colonne apparait de mon coté dans le global au même emplacement que celles des autres tableaux et non pas en AO. Une dernière question néanmoins, quand j'appuis sur le bouton, un grand nombre de ligne apparaissent quand j'appuie sur le bouton alors que ce n'est pas voulu. De plus, 5 lignes vides séparent à chaque fois et ce, dans le global, les dernières et premières lignes de chaque tableaux. Voici le fichier avant et après application de la macro
PS: je tiens à préciser que l'apparition de ces lignes contre ma volonté se fait seulement après la modification des colonnes.
 

Pièces jointes

  • 365219d1464544393-regroupement-de-plusieurs-tableaux-vba-classeur-regroupement.xlsx
    121.3 KB · Affichages: 36
  • apres-regroupement-de-plusieurs-tableaux-vba-classeur-regroupement.xlsm
    177.4 KB · Affichages: 58
Vote positif 0 Vote négatif
Marc L

Marc L

XLDnaute Occasionnel
Toujours en respectant les listes initiales …

VB: 
Sub Demo()
    Const FIN = "kuka"
    With Application: .Calculation = xlCalculationManual: .DisplayAlerts = False: .ScreenUpdating = False: End With
    With Feuil3.ListObjects(1)
            .DataBodyRange.Clear
            .Resize .HeaderRowRange.Resize(2)
             Worksheets(FIN).ListObjects(1).HeaderRowRange.Copy .Range(1)
            .Parent.Activate:  .Range(1).Select
        For W& = .Parent.Index + 1 To Worksheets(FIN).Index
            Worksheets(W).ListObjects(1).DataBodyRange.Copy .InsertRowRange
        Next
'            .DataBodyRange.Formula = .DataBodyRange.Value
    End With
   With Application: .Calculation = xlCalculationAutomatic: .DisplayAlerts = True: .ScreenUpdating = True: End With
End Sub
Edit : la ligne en commentaire ne conserve pas les formules d'origine …

_______________________________________________________________________________
Merci de cliquer sur J'aime ce post en bas à gauche de chaque message ayant aidé …
​
 
Dernière édition:
Vote positif 0 Vote négatif
S

Si...

XLDnaute Barbatruc
Re : Regroupement de plusieurs tableaux (VBA)

salut

c'est plus simple avec l'outil Tableau (Table)
Code: 
'à la sélection de l'onglet (donc avec mise à jour) 
Private Sub Worksheet_Activate()
  Application.ScreenUpdating = 0: Application.Calculation = xlCalculationManual
  Dim n As Byte, L As Long, R As Range
  If [TG].Item(1, 1) <> "" Then [TG].Delete
  For n = 0 To 5
    Set R = Array([TSI], [TC], [TA], [TT], [TS], [TK])(n)	'rajouter (enlever) des noms des tableaux en + (en -)
    L = IIf([TG].Item(1, 1) = "", 1, [TG].Rows.Count + 1)
    R.Copy [TG].Item(L, 1)
  Next
  Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub Worksheet_Deactivate()		'pas obligatoire, permet d'alléger le fichier
  If [TG].Item(1, 1) <> "" Then [TG].Delete
End Sub

Nota : je renomme les tableaux pour simplifier l'écriture du code
 

Pièces jointes

  • Regroupement Onglets.xlsm
    140.5 KB · Affichages: 55
Vote positif 0 Vote négatif

Discussions similaires

R
  • Question
Power Query Superposer des tableaux avec powerquery
Réponses
2
Affichages
181
Rabeto
R
D
  • Question
Microsoft 365 RECHERCHEV sur deux tableaux distincts avec une mise à jour automatique
Réponses
3
Affichages
125
chris
chris
D
  • Question
Microsoft 365 Fonction de Recherche de différents tableaux avec plusieurs résultats ?
2
Réponses
15
Affichages
327
Cousinhub
Cousinhub
J
  • Question
XL pour MAC Récupération de tableaux
Réponses
3
Affichages
190
Staple1600
Staple1600
Amigo
  • Question
XL 2019 Copier Nouvel enregistrement dans le tableau et les tableaux successifs
Réponses
4
Affichages
179
Amigo
Amigo
S
  • Question
Microsoft 365 Création d'un TCD avec 2 tableaux ayant les mêmes entêtes de colonne et les même données
Réponses
9
Affichages
264
STEPHANIE1975
S
A
  • Question
XL 2016 Copie automatisée des sous-catégories avec VBA
Réponses
8
Affichages
331
Lolote83
L
L
  • Résolu(e)
XL 2021 Regroupement de ligne en fonction d'une valeur identique
Réponses
6
Affichages
232
leoooooooooooooooooo
L
F
  • Question
Microsoft 365 Aide mise en forme tableau Excel
Réponses
0
Affichages
184
Fanfan1998
F
S
  • Question
Microsoft 365 Redimensionnement automatique des tableaux excel en liaison dans powerpoint (réduction de la taille)
Réponses
0
Affichages
114
samuelcouni
S

Membres actuellement en ligne

15 membres et 277 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 183
Messages
2 086 005
Membres
103 087
dernier inscrit
sarah.caneri