Discussion :

[Aurianelm]

Bonjour à tous,

J'ai un fichier excel (fichier de données) de 6 colonnes et x lignes.
Dans la 1ère colonne il y a des valeurs qui reviennent plusieurs fois.

J'ai un 2ème fichier Excel vide qui est ma maquette.

Je souhaite que pour chaque valeur différente il créé un nouvel onglet.
Pour chaque onglet, je souhaite qu'il copie les valeurs des cellules du fichier de données en les collant dans le bon onglet.

Précision : Si une valeur de ma colonne A du fichier de données apparaît x fois, dans l'onglet lui correspondant dans la maquette, il y aura x lignes.

Exemple :

Toto	Employé		12        etc...
Toto	Agriculteur	11 
Tata	Artisan		15
Tata	Employé		11
Tata	Commerçant	13 
Titi	Employé		12
Titi	Artisan		11
Titi	Agriculeur	10
Titi	Commerçant	12

Pour cet exmple je souhaite obtenir un onglet Toto avec 2 lignes :

Employé		12	etc...
Agriculteur	11	etc...

Un onglet Tata avec 3 lignes :

Artisan		12	etc...
Employé		11	etc...
Commerçant	13	etc...

et ainsi de suite jusqu'à ce qu'il n'y ait plus de données.

Le code que j'ai fait mais qui ne correspond pas :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Lancer_ETP()
Workbooks(base).Activate
j = 4
For i = 2 To nbligne
    Workbooks(maquette).Activate
    If FeuilleExiste(Workbooks(maquette), Workbooks(base).Sheets("onglet").Range("A" & i).Value) = False Then
        Sheets.Add
        ActiveSheet.Name = Workbooks(base).Sheets("onglet").Range("A" & i).Value
        Workbooks(base).Sheets("Onglet").Range("B" & i & ":F" & i).Copy
        ActiveSheet.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        j = j + 1
    End If
Next i
End Sub

Merci pour votre aide !

[mercatog]

Adapte à la ligne définissant le classeur Maquette.

Code en petites procédures pour la clareté

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Sub Eclatement()
Dim LastLig As Long, i As Long
Dim Wbk As Workbook
Dim Tb
 
Application.ScreenUpdating = False
Codes Tb
With ThisWorkbook.Worksheets("onglet")
    .AutoFilterMode = False
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
 
    '===Ligne suivante à adapter avec le fichier maquette
    Set Wbk = Workbooks(2)
    '===-------------------------------------------------
 
    For i = 0 To UBound(Tb)
        .Range("A1:A" & LastLig).AutoFilter Field:=1, Criteria1:=Tb(i)
        Transfer Wbk, .Range("B2:F" & LastLig), Tb(i)
        .AutoFilterMode = False
    Next i
End With
 
End Sub
 
Private Sub Codes(ByRef Tb)
Dim LastLig As Long, i As Long
Dim Dico As Object
 
With ThisWorkbook.Worksheets("onglet")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set Dico = CreateObject("Scripting.dictionary")
    Tb = .Range("A2:A" & LastLig)
    For i = 1 To LastLig - 1
        If Not Dico.exists(Tb(i, 1)) Then Dico.Add Tb(i, 1), ""
    Next i
    Erase Tb
    Tb = Dico.keys
    Set Dico = Nothing
End With
End Sub
 
Private Sub Transfer(ByVal Wbk As Workbook, ByVal Rng As Range, ByVal Nom As String)
Dim Ws As Worksheet
 
If Existe(Wbk, Nom) Then
    Set Ws = Wbk.Worksheets(Nom)
    Ws.UsedRange.Offset(3).Clear
Else
    Set Ws = Wbk.Worksheets.Add(After:=Wbk.Sheets(1))
    Ws.Name = Nom
End If
Rng.SpecialCells(xlCellTypeVisible).Copy
Ws.Range("A4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Set Ws = Nothing
End Sub
 
Private Function Existe(ByVal Wbk As Workbook, ByVal Nom As String) As Boolean
 
On Error Resume Next
Existe = Wbk.Sheets(Nom).Index
End Function

[Aurianelm]

ça marche nickel ! Merci beaucoup !!