Discussion :

[wyzer]

Bonjour,

Avant de commencer, voici un exemple :

Colonne A | Colonne B
          |
7001      | Richard
7001      | Marc
7001      | Lucie
7002      | Paul
7002      | Evelyne
7002      | Marie

Ce que j'aimerais faire, c'est qu'à chaque fois que la valeur change dans la colonne A, une nouvelle feuille est créée, avec comme nom la valeur de la cellule, en recopiant toute la ligne

Donc on va avoir une nommé 7001, et autre 7002


Depuis tout à l'heure je me casse la tête mais je n'y arrive pas

[Theze]

Bonjour,

A mettre dans le module de ta feuille :

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
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Existe As Integer
 
    If Not Intersect(Target, [A:A]) Is Nothing Then
 
        'définie la plage pour la recherche
        Set Plage = Range([A1], [A65536].End(xlUp))
 
        'compte le nombre de valeurs
        Existe = Application.CountIf(Plage, Target)
 
        'si une seule (celle de target), crée la feuille
        'la renomme avec la valeur de target et copie
        'la ligne entrière de target dans la nouvelle
        'feuille en partant de A1
        If Existe = 1 Then
 
            Set Fe = Worksheets.Add
            Fe.Name = Target.Value
            Target.EntireRow.Copy Fe.[A1]
 
        End If
 
    End If
 
    Set Plage = Nothing
    Set Fe = Nothing
 
End Sub

Hervé.

[wyzer]

merci !!

il me mets ce message d'erreur :

"erreur 424, objet requis"

[Theze]

Re,

Chez moi ça fonctionne très bien, sur quelle ligne as tu cette erreur ?

Hervé.

[Vadorblanc]

Bonjour
These
Super ça marche, je mets ton code de côté
Merci

[wyzer]

Re,

Chez moi ça fonctionne très bien, sur quelle ligne as tu cette erreur ?

Hervé.

Excuse de ne pas voir répondu plus tôt, mais je pensais être averti par mail dès qu'il y aurait une réponse

A cette ligne :

Code :

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

If Not Intersect(Target, [A:A]) Is Nothing Then

[Theze]

Bonsoir wyser,

remplace la ligne par :

Code :

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

1
2
 
If Not Intersect(Target, Range("A1:A65536")) Is Nothing Then

Hervé.

[wyzer]

C'est pareil

Le soucis ne viendrait pas du fait que j'ai enlevé "Private Sub" ?

Car je veux utiliser cette macro pour n'importe quel fichier Excel, donc je l'ai intégré dans mon classeur de macros personnelles

[ZebreLoup]

Sauf que la macro proposée par Theze est liée à un évènement. Tu peux mettre le code de la procédure dans une procédure publique que tu mets dans ton classeur perso, et ensuite, tu appelles cette procédure dans le worksheet_change de chaque feuille ou tu veux que ça fonctionne.

[Theze]

Bonsoir,

Oups, désolé de ne pas l'avoir précisé, mais effectivement comme te le dit ZebreLoup c'est une procédure évennementielle à mettre dans le module de la feuille en question ou alors modifier la proc et l'appeler depuis l'évennement "Worksheet_Change" en lui passant la feuille et la cellule (Target) en arguments.
La proc à mettre dans un module standard :

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
 
Public Sub AjoutFeuille(Feuille As Worksheet, Cel As Range)
 
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Existe As Integer
 
    If Not Intersect(Cel, Feuille.[A:A]) Is Nothing Then
 
        'définie la plage pour la recherche
        With Feuille
            Set Plage = .Range(.[A1], .[A65536].End(xlUp))
        End With
 
        'compte le nombre de valeurs
        Existe = Application.CountIf(Plage, Cel)
 
        'si une seule (celle de target), crée la feuille
        'la renomme avec la valeur de target et copie
        'la ligne entrière de target dans la nouvelle
        'feuille en partant de A1
        If Existe = 1 Then
 
            Set Fe = Worksheets.Add
            Fe.Name = Cel.Value
            Cel.EntireRow.Copy Fe.[A1]
 
        End If
 
    End If
 
    Set Plage = Nothing
    Set Fe = Nothing
 
End Sub

Appel de la proc dans le module de la feuille :

Code :

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

1
2
3
4
5
6
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    AjoutFeuille ActiveSheet, Target
 
End Sub

Hervé.

[wyzer]

En me relisant je viens de me rendre compte que je me suis mal exprimé

Je suis vraiment désolé !!

En fait ce que je voulais dire, c'est qu'à chaque fois que la valeur de la colonne est différente

Et non pas lorsque la valeur change

Car je travaille sur des fichiers que j'ai extrait de l'AS400, et pour les rendre plus lisible je voulais créer une macro qui tri mes données, en ayant une feuille par n° de client (colonne A)

[mercatog]

Un sujet similaire (à adapter, dans le code, il s'agit de la colonne F de feuil1)http://www.developpez.net/forums/d10...lutat-colonne/

[wyzer]

Merci !!

Voilà le code adapté :

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
Sub z_Classement_par_onglet()
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Dim Sh As Worksheet
Dim LastLig As Long, NewLig As Long, i As Long
Dim NomFeuil As String, fe As String
 
fe = ActiveWorkbook.ActiveSheet.Name
 
With Sheets(fe)
 
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
 
For i = 2 To LastLig
 
NomFeuil = CStr(.Range("A" & i).Value)
 
If NomFeuil <> "" Then
On Error Resume Next
Set Sh = Sheets(NomFeuil)
On Error GoTo 0
 
If Sh Is Nothing Then
Set Sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
Sh.Name = NomFeuil
.Rows(1).Copy Sh.Range("A1")
End If
 
NewLig = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row + 1
 
.Rows(i).Copy Sh.Range("A" & NewLig)
Set Sh = Nothing
 
End If
 
Next i
 
.Activate
 
End With
 
Sheets(fe).Delete
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub

[mercatog]

Ce qui revient à faire

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
Sub z_Classement_par_onglet()
Dim Sh As Worksheet
Dim LastLig As Long, NewLig As Long, i As Long
Dim NomFeuil As String
 
Application.ScreenUpdating = False
With ActiveSheet                                           'je préfère mettre le nom de la feuille With Sheets("MaFeuille")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 2 To LastLig
        NomFeuil = CStr(.Range("A" & i).Value)
        If NomFeuil <> "" Then
            On Error Resume Next
            Set Sh = Sheets(NomFeuil)
            On Error GoTo 0
            If Sh Is Nothing Then
                Set Sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                Sh.Name = NomFeuil
                .Rows(1).Copy Sh.Range("A1")
            End If
            NewLig = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row + 1
            .Rows(i).Copy Sh.Range("A" & NewLig)
            Set Sh = Nothing
        End If
    Next i
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
End With
End Sub