Copier onglets et coller dans onglet synthèse

Bonjour à tous,

Je souhaiterais copier les tableaux dans mes onglets quelques soient leurs nombres, à la suite en partant du premier onglet, dans un onglet synthèse. Sachant que les tableaux dans les onglets ont tous le même format, et que seulement les onglets commençant par "A_" doivent être pris en compte.

J'arrive à sélectionner le tableau, mais pas à le coller dans l'onglet synthèse, et surtout je veux pouvoir l'automatiser, et j'arrive seulement à le faire pour un seule cas.

Je vous remercie pour toute l'aide que vous pourrez m'apporter.

Merci beaucoup

Filou93

Bonjour,

Sub actualiser()
ligne = 2
nbcolonnes = 8
effacer
Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            If .Name Like "A_*" Then
                debut = 4
                fin = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = debut To fin
                    For j = 1 To nbcolonnes
                        Cells(ligne, j) = .Cells(i, j)
                    Next
                    ligne = ligne + 1
                Next i
            End If
        End With
    Next
End Sub
Sub effacer()
ligne = 2
nbcolonnes = 8
    fin = Cells(ligne, 1).End(xlDown).Row
    Range(Cells(ligne, 1), Cells(fin, nbcolonnes)).Clear
End Sub

Bonjour,

à tester,

Sub test()
Dim f As Worksheet, rw As Long, col As Integer, source As String, dest As Long
For Each f In Worksheets
    If f.Name <> "Synthese" Then
        If Left(f.Name, 1) = "A" Then
         rw = f.Cells(Rows.Count, 1).End(xlUp).Row
         col = f.Cells(3, Columns.Count).End(xlToLeft).Column
         source = Range(Cells(4, 1).Address, Cells(rw, col).Address).Address
         dest = Sheets("Synthese").Cells(Rows.Count, 1).End(xlUp).Row + 1
         f.Range(source).Copy Sheets("Synthese").Range("A" & dest)
        End If
    End If
Next f
End Sub

Merci Isabelle

c'est mieux que mon code que j'avais écrit il y a des lustres !

Bonjour,

Une autre proposition.

Cdlt.

Public Sub Consolidate_data()
Dim ws As Worksheet, ws2 As Worksheet, rng As Range, rw As Long, i As Long
    Set ws2 = ActiveSheet
    ws2.Cells(3, 1).CurrentRegion.Clear
    For i = 1 To Worksheets.Count
        Set ws = Worksheets(i)
        If ws.Name <> ws2.Name And Left(ws.Name, 2) = "A_" Then
            Set rng = ws.Cells(3, 1).CurrentRegion
            If i = 1 Then
                rng.Copy Destination:=ws2.Cells(3, 1)
                rw = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            Else
                rng.Offset(1).Resize(rng.Rows.Count - 1).Copy Destination:=ws2.Cells(rw, 1)
            End If
        End If
    Next i
End Sub

J'ai honte d'avoir produit une version que je faisais il y a 5 ans ... voici ma proposition !! juste pour ne pas paraître idiot !

Option Explicit

Sub compiler()
Dim ligne As Long, ws As Worksheet
    With ActiveSheet.ListObjects(1).DataBodyRange
      If .Rows.Count > 1 Then
        .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
      End If
    End With
    ligne = 2
    For Each ws In Worksheets
        If ws.Name Like "A_*" Then
            ws.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1, 0).Resize(ws.Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Rows.Count - 1).Copy Destination:=ActiveSheet.Cells(ligne, 1)
            ligne = Cells(Rows.Count, 1).End(xlUp).Row + 1
        End If
    Next
End Sub

Re,

@ Steelson,

Pour info.,

With ActiveSheet.ListObjects(1).DataBodyRange
      If .Rows.Count > 1 Then
        .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
      End If
End With

peut se résumer à :

With ActiveSheet.ListObjects(1)
      If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
End With

Cdlt.

Merci beaucoup pour votre aide à tous c'est exactement ce qu'il me fallait.

Je vous souhaite une bonne soirée et merci encore,

Filou93

Bonjour,

J'ai essayer de rajouter du code pour répondre à mes besoins, en fait le nom du projet sera en case C1, il faudrait que dans chaque onglet je puisse compter le nombre de ligne, et mettre le nom du projet NB ligne de fois, pour différencier chaque projet dans l'onglet "Synthese", j'ai essayer dans un premier temps de compter les lignes pour tester j'ai mis la case S1, mais ça me met 0.

Pourriez-vous m'aider s'il vous plaît?

Merci d'avance,

Filou93

Bonjour,

Une proposition à étudier.

Toutes les données sont sous forme de tableaux (ou table de données).

A te relire.

Cdlt.

Je te remercie Jean-Eric, je l'ai tester, au début ça marchait puis j'ai eu un beug sur la ligne

Set lo2 = ws2.ListObjects(1)

, j'ai une erreur 9.

Je ne souhaite pas l'afficher sous forme de tableau comme ça.

Je te remercie pour ta proposition.

Filou93

Bonjour,

J'ai un gros soucis dans le code, il prend en compte seulement les 2 premiers onglets, pas au dessus de 2.

Pouvez-vous m'aider s'il vous plaît?

Dim ws As Worksheet, ws2 As Worksheet, rng As Range, rw As Long, i As Long
    Set ws2 = ActiveSheet
    ws2.Cells(4, 2).CurrentRegion.Clear
    For i = 1 To Worksheets.Count
        Set ws = Worksheets(i)
        If ws.Name <> ws2.Name And Left(ws.Name, 2) = "A_" Then
            Set rng = ws.Cells(4, 2).CurrentRegion
            If i = 1 Then
                rng.Copy Destination:=ws2.Cells(4, 2)
                rw = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
            Else
                rng.Offset(1).Resize(rng.Rows.Count - 1).Copy Destination:=ws2.Cells(rw, 2)
            End If
        End If
    Next i

Merci d'avance,

Filou93

Tes données commencent bien à la ligne 4 dans tous les onglets ?

Sinon ... https://forum.excel-pratique.com/viewtopic.php?p=740063#p740063 qui s'adaptera ! si le nom ne commence pas par un espace !!

Merci de ta réponse,

Oui ils commencent bien à la quatrième ligne, mon soucis c'est que ça copie pas plus de 2 onglets c'est bizarre, j'ai essayer ton code, il marche mais il ne fait pas de mise à jour contrairement à celui que j'ai posté, je peux cliquer plusieurs fois ils copiera plusieurs fois la même chose à la suite.

Merci en tout cas

Filou93

Déplace la ligne rw avant le if sur le code de Jean-Eric

            rw = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            If i = 1 Then
                rng.Copy Destination:=ws2.Cells(3, 1)
            Else
                rng.Offset(1).Resize(rng.Rows.Count - 1).Copy Destination:=ws2.Cells(rw, 1)
            End If

Merci c'est parfait ça marche nickel !

Merci beaucoup vraiment