Copie de plusieurs onglets vers un seul

Version imprimable

22/06/2012, 23h37
sebizar

1 pièce(s) jointe(s)

Copie de plusieurs onglets vers un seul

Bonjour à tous,

je sais que la question a déja été quelque fois posée mais après avoir essayé de récupérer les solutions proposées ici ou sur d'autres forum, je sèche...:?

Je vous expose mon pb :

J'ai plusieurs onglets dont le nombre de colonnes est fixe. Les entêtes de colonnes sont identiques, mais le nombre de lignes est variable.

J'aimerai que ma macro puisse récupérer le contenu du tableau de chaque onglet (sans copier la première ligne qui est à chaque fois la ligne des intitulés de colonne) et le copier/compiler à la suite dans un onglet synthèse.

Merci d'avance pour votre aide !

Salut, à adapter à ton contexte.Comme il y a une macro il faudra sauver ton fichier en xlsm ou xlsb.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Option Explicit
 
Sub ConcatenationFeuilles()
Dim i As Long, T() As Variant
 
    Application.ScreenUpdating = False
    ShConcat.Cells.Clear
 
    ' Copie En-Tête
    ' Au cas ou la feuille de synthèse se trouverait en 1ere position
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> ShConcat.Name Then
            With Worksheets(i)
                T = .Range("A1:P1").Value
                ShConcat.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
            Exit For
        End If
    Next i
 
    '   Copie des données
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> ShConcat.Name Then
            With Worksheets(i)
                T = .Range("A2:P" & .Range("A" & Rows.Count).End(xlUp).Row).Value
                ShConcat.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
        End If
    Next i
    Erase T
    Application.ScreenUpdating = True
End Sub

ShConcat étant le CodeName de la feuille "synthèse"
Pour le CodeName voir ici
Les avantages du CodeName étant que l'utilisateur peut changer le nom d'onglet des feuilles, ajouter des feuilles ou en déplacer sans avoir à retoucher au code VBA.

Bonsoir sebizar,

Je te propose un code beaucoup plus long que celui de kiki29.
Plus long mais je le comprend bien ;)

L'objectif, créer un onglet "TOTAL" (ou synthèse si tu veux l'adapter) :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Sub faitotalonglet()
'---------------------------------------------------------------------------------------
'Macro qui copie toutes les lignes (hormis les intitulés de colonne) de tous les onglets
'et créer un nouvel onglet "TOTAL" composé de l'ensemble des lignes
'---------------------------------------------------------------------------------------
 
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim t(16) As String
 
    'Initialisation des intitulés de colonne
    t(1) = "CSP"
    t(2) = "N° Formation"
    t(3) = "Intitulé1"
    t(4) = "Intitulé2"
    t(5) = "Objectifs1"
    t(6) = "Objectifs2"
    t(7) = "Moyen_evaluation1"
    t(8) = "Moyen_evaluation2"
    t(9) = "Organisme1"
    t(10) = "Organisme2"
    t(11) = "Début_session1"
    t(12) = "Début_session2"
    t(13) = "Statut"
    t(14) = "Catégorie"
    t(15) = "Nom"
    t(16) = "Prénom"
 
    'Création d'un nouvel onglet TOTAL
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "TOTAL"
 
    'chargement des intitulés de colonne
    For i = 1 To 16
        Cells(1, i).Value = t(i)
    Next
 
    'Mise en forme des intitulés
    Range("A1:P1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    With Selection.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
    End With
 
    'Parcours la collection en évitant la feuille "TOTAL"
    For Each Fe In ThisWorkbook.Worksheets
 
        If Fe.Name <> "TOTAL" Then
 
            With Fe
                'définie la plage sans la ligne de titres
               Set Plage = .Range(.Cells(2, 1), .Cells(.Cells.Find("*", .[A1], -4123, , 1, 2).Row, .Cells.Find("*", .[A1], -4123, , 2, 2).Column))
            End With
 
            'colle les valeurs dans la feuille "TOTAL"
            'après la dernière ligne non vide
            Plage.Copy Worksheets("TOTAL").Range("A65500").End(xlUp).Offset(1, 0)
 
        End If
 
    Next Fe
 
End Sub

Bertrand

23/06/2012, 03h43
kiki29

Salut Bertrand , non seulement plus long mais aussi plus lent ;)
23/06/2012, 07h48
Bear the french

Bonjour Kiki29,

Oui, mon algorithme fonctionne, c'est pour l'instant suffisant pour moi qui apprend à pratiquer le vba en autodidacte :oops:
En terme d'efficacité, je suis bien certain que le tien doit être plus rapide :ccool:

Bertrand

Bonsoir Kiki29,

Ton code post #2 retient en T le nombre de lignes calculées sur la base de la colonne A. Hors la colonne A peut avoir des zones avec une ou plusieurs cellules vides. Dans la même idée, la colonne A peut être plus "courte" que les autres (courte = avec moins de lignes).

Mes tests (peut-être que j'ai mal adapté ton code :roll:) me semble me donner raison sur ce point. Est correct de dire que la colonne A ne doit pas avoir de cellule vide pour fonctionner et doit être la colonne la plus grande de toute en nombre d'éléments ?

Bertrand
25/06/2012, 03h34
kiki29

Salut,
C'est vrai que cela est sous entendu :

Citation:

à adapter à ton contexte

Selon le contexte on pourra utiliser UsedRange, CurrentRegion etc.

Le problème ici est ailleurs et tu n'as ni modifié ni testé correctement le code.