XL 2016 Reunir plusieurs onglets excel dans un seul

[Valeff]

Bonjour à tous,
Dans le fichier ci-joint je souhaite qu'apparaissent dans le dernier onglet l'intégralité des lignes se situant dans le 3 premiers onglets.
Merci pour votre aide

 

[job75]

Bonjour Valeff, bienvenue sur XLD,

Voyez le fichier joint et cette macro dans le code de la feuille "Consolidation" :

Private Sub Worksheet_Activate()
Dim P1 As Range, h1&, P2 As Range, h2&, P3 As Range, h3&
Set P1 = Feuil1.UsedRange.EntireRow: h1 = P1.Rows.Count
Set P2 = Feuil2.UsedRange.EntireRow: h2 = P2.Rows.Count
Set P3 = Feuil3.UsedRange.EntireRow: h3 = P3.Rows.Count
With [A5] 'cellule à adapter
    P1.Copy .Cells
    P2.Copy .Offset(h1)
    P3.Copy .Offset(h1 + h2)
    .Offset(h1 + h2 + h3).Resize(Rows.Count - h1 - h2 - h3 - .Row + 1).EntireRow.Delete 'RAZ en dessous
End With
Columns.AutoFit 'ajustement largeur
With UsedRange: End With 'actualise les barres de défilement
End Sub

Elle se déclenche quand on active la feuille.

A+

 

[job75]

Bonjour le forum,

Fichier (2), avec des titres en A1 ce n'est guère plus compliqué :

Private Sub Worksheet_Activate()
Dim P1 As Range, h1&, P2 As Range, h2&, P3 As Range, h3&
Set P1 = Feuil1.UsedRange.EntireRow.Offset(4): h1 = P1.Rows.Count - 4: If h1 < 0 Then h1 = 0
Set P2 = Feuil2.UsedRange.EntireRow.Offset(4): h2 = P2.Rows.Count - 4: If h2 < 0 Then h2 = 0
Set P3 = Feuil3.UsedRange.EntireRow.Offset(4): h3 = P3.Rows.Count - 4: If h3 < 0 Then h3 = 0
With [A5] 'cellule à adapter
    P1.Copy .Cells
    P2.Copy .Offset(h1)
    P3.Copy .Offset(h1 + h2)
    .Offset(h1 + h2 + h3).Resize(Rows.Count - h1 - h2 - h3 - .Row + 1).EntireRow.Delete 'RAZ en dessous
End With
Columns.AutoFit 'ajustement largeur
With UsedRange: End With 'actualise les barres de défilement
End Sub

A+

 

[Valeff]

Merci beaucoup Job 75, mais ne maitrisant pas les macros ou VBA, dans l'avenir mon fichier contient + de 3 ongles, comment j'adapte la macro. Dois-je insérer manuellement les pages à la suites de set P3 et P3 copy offset ? Dans l'attente de votre retour et Merci par avance pour votre temps et aide.

 

[job75]

Bonjour Valeff, le forum,

Voyez ce fichier (3) et cette macro qui fonctionne quel que soit le nombre de feuilles :

Private Sub Worksheet_Activate()
Dim titres&, dest As Range, w As Worksheet, P As Range, h&
titres = 4 'nombre de lignes des titres, à adapter
Set dest = Cells(titres + 1, 1) '1ère cellule de destination
For Each w In Worksheets
    If w.Name <> Me.Name Then
        Set P = w.UsedRange.EntireRow.Offset(titres): h = P.Rows.Count - titres: If h < 0 Then h = 0
        P.Copy dest 'copier-coller
        Set dest = dest.Offset(h) 'décale la cellule de destination
    End If
Next
dest.Resize(Rows.Count - dest.Row + 1).EntireRow.Delete 'RAZ en dessous
Columns.AutoFit 'ajustement largeur
With UsedRange: End With 'actualise les barres de défilement
End Sub

Bonne journée.