Discussion :

[apprenant16]

Bonjour,

J'essaie d'exécuter ce code pour créer une feuille en fonction de chaque occurrence unique et copier le tableau des données y relatives.

J'ai le message d'erreur et je souhaite votre aide pour le corriger :

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
Sub CreerFeuillesOccurrenceUnique()
 
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim rngSource As Range
    Dim cell As Range
    Dim dict As Object
    Dim id As String
    Dim i As Integer
    Dim compteur As Integer
 
    ' Initialiser le compteur
    compteur = 1
 
    Set wsSource = ThisWorkbook.Sheets("Feuil1")
    Set rngSource = wsSource.Range("N:N")
 
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
 
    ' Créer une feuille pour chaque occurrence unique
    For Each cell In rngSource
        id = cell.Value
        If Not dict.exists(id) And id <> "" Then
            Set wsDest = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
            wsDest.Name = Left(id, 10) & compteur
            compteur = compteur + 1
            dict.Add id, wsDest
        End If
    Next cell
 
    ' Copier le tableau dans les nouvelles feuilles
    For i = 1 To dict.Count
        Set wsDest = dict.Items(i - 1)
 
        wsSource.UsedRange.Copy Destination:=wsDest.Range("A1")
    Next i
 
End Sub

[Jean-Philippe André]

Salut,

lorsque tu cliques sur débogage, sur quelle ligne de ton code VBE se positionne stp ?

[Volid]

Regarder ce code

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
Sub CreerFeuillesOccurrenceUnique()
 
    Dim wsSource As Worksheet
    Dim wsDest
    Dim rngSource As Range
    Dim cell As Range
    Dim dict As Object
    Dim id As String
    Dim i As Integer, LastEmpty As Long
    Dim compteur As Integer
 
    ' Initialiser le compteur
    compteur = 1
 
    Set wsSource = ThisWorkbook.Sheets("Feuil1")
    LastEmpty = wsSource.Cells(wsSource.Rows.Count, "N").End(xlUp).Row
    Set rngSource = wsSource.Range("N1:N" & LastEmpty)
 
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
 
    ' Créer une feuille pour chaque occurrence unique
    For i = 1 To LastEmpty
        id = wsSource.Range("N" & i).Value
        If Not dict.exists(id) And id <> "" Then
             Set wsDest = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
             wsDest.Name = Left(id, 10) & compteur
            compteur = compteur + 1
            dict.Add id, wsDest
        End If
    Next
   Dim u
    u = dict.Items
    ' Copier le tableau dans les nouvelles feuilles
    For i = 0 To dict.Count - 1
        Set wsDest = u(i)
        wsSource.UsedRange.Copy Destination:=wsDest.Range("A1")
    Next i
 
End Sub

[apprenant16]

Salut,

lorsque tu cliques sur débogage, sur quelle ligne de ton code VBE se positionne stp ?

En mode débogage, la ligne 34 est coloriée en jaune : Set wsDest = dict.Items(i - 1)Merci

[apprenant16]

Bonjour,

@Volid : la création des feuilles pour chaque item unique de la colonne N se fait parfaitement avec votre code, mais c'est l'intégralité des données qui est copiée également.

L'idée c'est de ne copier que les données qui correspondent avec l'identifiant unique (comme un filtre), ainsi chaque onglet n'affichera que les données qui le concerne en se basant sur la colonne N.

Merci d'avance de votre aide

Regarder ce code

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
Sub CreerFeuillesOccurrenceUnique()
 
    Dim wsSource As Worksheet
    Dim wsDest
    Dim rngSource As Range
    Dim cell As Range
    Dim dict As Object
    Dim id As String
    Dim i As Integer, LastEmpty As Long
    Dim compteur As Integer
 
    ' Initialiser le compteur
    compteur = 1
 
    Set wsSource = ThisWorkbook.Sheets("Feuil1")
    LastEmpty = wsSource.Cells(wsSource.Rows.Count, "N").End(xlUp).Row
    Set rngSource = wsSource.Range("N1:N" & LastEmpty)
 
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
 
    ' Créer une feuille pour chaque occurrence unique
    For i = 1 To LastEmpty
        id = wsSource.Range("N" & i).Value
        If Not dict.exists(id) And id <> "" Then
             Set wsDest = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
             wsDest.Name = Left(id, 10) & compteur
            compteur = compteur + 1
            dict.Add id, wsDest
        End If
    Next
   Dim u
    u = dict.Items
    ' Copier le tableau dans les nouvelles feuilles
    For i = 0 To dict.Count - 1
        Set wsDest = u(i)
        wsSource.UsedRange.Copy Destination:=wsDest.Range("A1")
    Next i
 
End Sub

[Volid]

L'idée c'est de ne copier que les données qui correspondent avec l'identifiant unique (comme un filtre), ainsi chaque onglet n'affichera que les données qui le concerne en se basant sur la colonne N.

Dans ce cas appliquer le filtre avant l'exportation on peut le faire dans la première boucle, le reste du code la partie qui provoque l'erreur est superflue vous pouvez la retirer

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
     For i = 1 To LastEmpty
        id = wsSource.Range("N" & i).Value
        If Not dict.exists(id) And id <> "" Then
             Set wsDest = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
             wsDest.Name = Left(id, 10) & compteur
            compteur = compteur + 1
 
			' appliquer le filtre ici filtre = id 
			' et après copier les donnés de wsSource vers wsDest
 
            dict.Add id, wsDest
        End If
    Next