vba dupliquer certaines en-tête sur plusieurs tableaux sur une même feuille

Fifi76

XLDnaute Nouveau
bonjour,

je me permets de vous demander de l'aide après des jours de recherche … sans résultat

Pour un projet professionnel, je souhaiterais pouvoir dupliquer dans tous les tableaux d'une même page certaines en-tête de tableau

Le nombre de tableau peut varier
Le nombre de collaborateurs aussi (nombre de colonnes consacrées par les "collaborateurs" peut être fixe)
Le nombre de ligne par tableau évolue
La 1ere en-tête des tableaux varie d'un tableau à l'autre

Les en-têtes à dupliquer sont les Collab1,...
en précisant que les noms seront toujours en évolution

J'ai essayé avec une cellule active, mais trop contraignant … il peut y avoir 20-25 tableaux
J'ai un niveau très très débutante en vba

Merci beaucoup pour votre aide
 

Pièces jointes

  • exemple TABLEAU.xlsm
    55.9 KB · Affichages: 14

Dranreb

XLDnaute Barbatruc
Bonjour.
Sous réserve d'avoir compris ce qu'étaient les Collab1,… (j'ai estimé que c'était B9:AF9) :
VB:
Sub test()
Dim TEnt(), LOt As ListObject
TEnt = Feuil2.[B9:AF9].Value
For Each LOt In Feuil2.ListObjects
   LOt.HeaderRowRange(1, 2).Resize(, UBound(TEnt, 2)).Value = TEnt
   Next LOt
End Sub
 

Dranreb

XLDnaute Barbatruc
C'est le nom de l'objet Worksheet de la rubrique Microsoft Excel Objets qui représente la feuille Excel nommée "Tâches Détaillées"
Moi je change toujours leur propriété Name en quelque chose de mnémonique commençant par "Wsh". Par exemple ici "WshTâchDét"
Certains parlent du CodeName de la feuille. Mais c'est un peu autre chose: c'est une propriété String qui reproduit le nom de l'objet Worksheet du projet VBA, qui la représente. Par exemple vous avez une feuille Excel nommée "Feuil2", et bien son CodeName vaut "Feuil6".
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Fifi76, Bernard,

Voyez le fichier joint et cette macro dans Module1 :
Code:
Sub CopierEnTêtes()
Dim entetes As Range, ncolab%, c As Range, P As Range
Set entetes = Feuil2.[B9:AF9] 'à adapter
ncolab = 20 'nombre de collaborateurs, à adapter
For Each c In entetes(1).EntireColumn.SpecialCells(xlCellTypeConstants)
        If c.Orientation = xlUpward Then _
            Set P = Union(IIf(P Is Nothing, Intersect(entetes.EntireColumn, c.EntireRow), P), Intersect(entetes.EntireColumn, c.EntireRow))
Next
Application.ScreenUpdating = False
If Not P Is Nothing Then entetes.Copy P: P.Offset(, ncolab).Columns.AutoFit 'copier-coller et ajustement largeur
'---réglage du zoom---
entetes.Parent.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto entetes.Parent.[A1], True 'cadrage
entetes(1, 0).Resize(, entetes.Count + 1).Select
ActiveWindow.Zoom = True
entetes.Parent.[A1].Select
End Sub
Elle fonctionnera même si les tableaux ne sont pas organisés en tableaux Excel.

Les formats de la plage B9:AF9 sont copiés et les largeurs des colonnes de V9:AF9 sont ajustées.

Le zoom de la fenêtre est réglé sur la plage A9:AF9.

A+
 

Pièces jointes

  • exemple TABLEAU(1).xlsm
    69.5 KB · Affichages: 14

job75

XLDnaute Barbatruc
Re,

Votre macro dans Module2 nécessitait une révision :
Code:
Sub Macro_inserer_une_ligne()
'Touche de raccourci du clavier: Ctrl+a
If CStr([B2]) = "" Then Exit Sub
Dim c As Range
With Feuil2.[A:A]
    Set c = .Find(CStr([B2]), , xlValues, xlWhole)
    If c Is Nothing Then MsgBox "Activité introuvable en colonne A...": Exit Sub
    Set c = .Find("=", c, xlFormulas, xlPart) 'formule SOUS.TOTAL
End With
c.EntireRow.Insert
If IsNumeric(Right(c(-1), 1)) Then c(-1).AutoFill c(-1).Resize(2) 'incréméntation éventuelle
End Sub
Fichier (2)

A+
 

Pièces jointes

  • exemple TABLEAU(2).xlsm
    71.7 KB · Affichages: 16

Discussions similaires

Statistiques des forums

Discussions
311 740
Messages
2 082 047
Membres
101 880
dernier inscrit
Anton_2024