Discussion :

[Youdi]

Bonjour,

Voilà je suis nouvelle en VBA et je bloque depuis ce matin à cause d'un problème (cf titre) que je n'arrive pas à résoudre.

L'objectif :

A partir d'une feuille source contenant un tableau, j'aimerais pouvoir créer une nouvelle feuille pour chaque nom différents présents dans une seule des colonnes du tableau. Ensuite il faut copier les lignes de chaque nom, dans la feuille correspondante (qui vient d'être crée à son nom).

- Pour cela j'ai d'abord réalisé un code qui me permet de copier coller sur une nouvelle feuille toutes les lignes qui m'intéresse du tableau de la premiere feuille.

- J'ai ensuite réalisé un code permettant de créer une feuille pour chacun des noms présents dans la colonne du tableau de la premiere feuille.

J'ai donc ensuite essayé de faire un mélange des deux codes pour obtenir mon code final mais c'est là que ca bloque et je ne comprends pas pourquoi

- Voilà le premier code qui permet de copier coller sur une nouvelle 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
Sub Test()
 
Dim Lig     As Long
  Dim Col     As String
  Dim NbrLig  As Long
  Dim NumLig  As Long
 
  Sheets("feuil2").Activate ' feuille de destination
 
  Col = "D"                 ' colonne données non vides à tester'
  NumLig = 0          'Numero de la 1ere ligne de collage '
  With Sheets("feuil1")     ' feuille source'
  NbrLig = .Cells(65536, Col).End(xlUp).Row 'Nombre de ligne
  For Lig = 2 To NbrLig             'n° de la 1ere ligne de données à partir de laquelle on commence jusqu'à NbrLig'
    If .Cells(Lig, Col).Value = "EHCA" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Sheets("feuil2").Cells(NumLig, 1).Insert Shift:=xlDown
            'ici pour insérer ou  .Paste pour coller'
    End If
  Next
  End With
End Sub

- Voilà maintenant le deuxième code qui permet de créer des nouvelles feuilles :

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
Option Explicit
 Dim maColonne As Integer

Sub AjoutFeuilles()
 Dim derLi As Long
 Dim i As Integer
 Dim maFeuille As Worksheet
 Set maFeuille = ActiveSheet[/COLOR]
 maColonne = 4  ' numéro de colonne a ajuster, ici c'est 1
 derLi = Columns(maColonne).Find("*", , , , , xlPrevious).Row 'derniere ligne, derli = 13 par ex'
 For i = 2 To derLi ' 2 si ligne de titre
 'Si la feuille existe déjà, on passe à la ligne suivante
 If FeuilleExiste(maFeuille.Cells(i, maColonne)) Then GoTo Suivant
 ' ajout d'une feuille à la fin
 Sheets.Add after:=Sheets(Worksheets.Count)
 ' nom de la feuille = valeur de la cellule
 Sheets(Worksheets.Count).Name = maFeuille.Cells(i, maColonne)
[COLOR=#FF0000]Dim Lig     As Long
  Dim Col     As String
  Dim NbrLig  As Long
  Dim NumLig  As Long
  
Sheets(Worksheets.Count).Activate ' feuille de destination
Col = "D"                 ' colonne données non vides à tester'
  NumLig = 0          'Numero de la 1ere ligne de collage '
  With Sheets("feuil1")     ' feuille source'
  NbrLig = .Cells(65536, Col).End(xlUp).Row 'Nombre de ligne
  For Lig = 2 To NbrLig             'n° de la 1ere ligne de données à partir de laquelle on commence jusqu'à NbrLig'
    If .Cells(Lig, Col).Value = "maFeuille.Cells(i, maColonne)" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Sheets(Worksheets.Count).Cells(NumLig, 1).Insert Shift:=xlDown
            'ici pour insérer ou  .Paste pour coller'
    End If
  Next
  End With

Suivant:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
 Next
 'on retourne à la feuille d'origine
 maFeuille.Select
 Set maFeuille = Nothing
 End Sub
 Function FeuilleExiste(Nom$) As Boolean 'Ti
 On Error Resume Next
 FeuilleExiste = Sheets(Nom).Name <> ""
 End Function
 Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = maColonne Then AjoutFeuilles
 End Sub

Et maintenant, le mix des deux codes en changeant quelques variable
bien sur :

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
Option Explicit
 Dim maColonne As Integer
 
Sub AjoutFeuilles()
 Dim derLi As Long
 Dim i As Integer
 Dim maFeuille As Worksheet
 Set maFeuille = ActiveSheet
 maColonne = 4  ' numéro de colonne a ajuster, ici c'est 1
derLi = Columns(maColonne).Find("*", , , , , xlPrevious).Row 'derniere ligne, derli = 13 par ex'
 For i = 2 To derLi ' 2 si ligne de titre
 'Si la feuille existe déjà, on passe à la ligne suivante
 If FeuilleExiste(maFeuille.Cells(i, maColonne)) Then GoTo Suivant
 ' ajout d'une feuille à la fin
 Sheets.Add after:=Sheets(Worksheets.Count)
 ' nom de la feuille = valeur de la cellule
 Sheets(Worksheets.Count).Name = maFeuille.Cells(i, maColonne)
Dim Lig     As Long
  Dim Col     As String
  Dim NbrLig  As Long
  Dim NumLig  As Long
 
Sheets(Worksheets.Count).Activate ' feuille de destination
Col = "D"                 ' colonne données non vides à tester'
  NumLig = 0          'Numero de la 1ere ligne de collage '
  With Sheets("feuil1")     ' feuille source'
  NbrLig = .Cells(65536, Col).End(xlUp).Row 'Nombre de ligne
  For Lig = 2 To NbrLig             'n° de la 1ere ligne de données à partir de laquelle on commence jusqu'à NbrLig'
    If .Cells(Lig, Col).Value = "maFeuille.Cells(i, maColonne)" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Sheets(Worksheets.Count).Cells(NumLig, 1).Insert Shift:=xlDown
            'ici pour insérer ou  .Paste pour coller'
    End If
  Next
  End With

Suivant:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
 Next
 'on retourne à la feuille d'origine
 maFeuille.Select
 Set maFeuille = Nothing
End Sub
 Function FeuilleExiste(Nom$) As Boolean 'Ti
 On Error Resume Next
 FeuilleExiste = Sheets(Nom).Name <> ""
 End Function
 Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Column = maColonne Then AjoutFeuilles
 End Sub

Et là grosse cata : " Erreur d'execution '91' : Variable objet ou variable de bloc With non définie "

Merci à celui ou celle qui pourra m'aider, je suis nouvelle en VBA et je ne comprends pas du tous d'où vient l'erreur :'(

[camarchepas]

Bonjour, récemment j'ai fais se fichier (Consolider.xlsm) pour un cas sensiblement similaire http://www.developpez.net/forums/d15...r-onglet-date/
Si le principe convient je peux éventuellement l'adapter à votre fichier sous réserve de l'avoir entre les mains

[joe.levrai]

Bonjour,

si j'ai bien compris, il faut :

- récupérer une liste sans doublon des valeur de la colonne MaColonne située dans la feuille "feuil1"

- pour chacune de ces valeurs :
* créer une feuille portant le nom "valeur" (si la feuille existe, on nettoie la feuille simplement)
* exporter toutes les lignes contenant "valeur" dans la colonne MaColonne


Je te propose une autre piste, d'autant plus rapide (par rapport à ta méthode) que ta BDD est grosse

j'ai testé sur une de mes BDD (200 000 lignes avec 142 "valeurs" différentes) sans problème et en 20 secondes : j'ai mes 142 feuilles avec leurs données

A noter que j'utilise les filtres automatiques pour écrire moins de lignes de codes ... mais un filtre avancé aurait fait aussi bien l'affaire (et peut être un poil plus rapide, 1 seconde peut être)

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
65
66
67
68
69
70
71
72
Option Compare Text
 
Function SansDoublon(Sh As Worksheet, ColonneAExtraire As Long)
' Génère une liste sans doublon des valeurs d'une colonne
' Débute en ligne 2 et s'arrête à la première ligne vide
Dim Liste, i As Long, Table()
Set Liste = CreateObject("Scripting.dictionary")
 
With Sh.Cells(2, ColonneAExtraire)
    ' on met toute la colonne dans un tableau
    Table = .Resize(.End(xlDown).Row - 1, 1).Value
 
    ' on analyse chaque valeur
    For i = LBound(Table, 1) To UBound(Table, 1)
        ' si elle n'existe pas dans le dictionnaire, on l'ajoute
        If Not Liste.exists(Table(i, 1)) Then Liste.Add Table(i, 1), Table(i, 1)
    Next i
End With
 
' si on a au moins un résultat
If Liste.Count > 0 Then
    ' on renvoie un tableau contenant les valeurs sans doublon
    SansDoublon = Application.Transpose(Liste.keys)
End If
 
End Function
 
Sub test()
Dim Tableau()
Dim ShSource As Worksheet
Dim MaColonne As Long
 
Set ShSource = ThisWorkbook.Worksheets("feuil1")
MaColonne = 4
 
' on récupère la liste sans doublon des "valeurs"
Tableau = SansDoublon(ShSource, MaColonne)
 
Application.ScreenUpdating = False
 
' pour chaque valeur
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
 
    ' on neutralise les erreurs
    On Error Resume Next
    ' on affecte la feuille à une variable + on nettoie la feuille
    Set Sh = Worksheets(Tableau(i, 1)): Sh.UsedRange.Delete
 
    ' si on a une erreur, ça veut dire que la feuille n'existe pas
    If Err.Number <> 0 Then
        ' on crée la feuille et la renomme
        Set Sh = Worksheets.Add
        Sh.Name = Tableau(i, 1)
        Err.Clear
    End If
 
    ' ici, on va utiliser le filtre automatique pour exporter les données dans chaque feuille
    With ShSource
        ' désactive les filtres auto
        .AutoFilterMode = False
        ' filtre sur MaColonne pour avec "valeur" comme critère
        .Range("A1").AutoFilter MaColonne, Tableau(i, 1)
        ' on copie le résultat du filtre auto dans la feuille de "Valeurs"
        ShSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
    End With
Next i
' on enlève les filtres
ShSource.AutoFilterMode = False
 
Application.ScreenUpdating = True
 
End Sub

tiens nous au courant

[Youdi]

Joe.Levrai, merci énormement pour votre code, c'est exactement ce que je cherchais à faire, je ne pouvais espérer mieux!!!

Encore merci

[joe.levrai]

Re bonjour,

j'ai oublié une ligne de code

à placer à la ligne 56

Code :

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

On Error Goto 0

[camarchepas]

Politesse et respect = 0 pour les deux.

[Youdi]

J'ai testé le même code sur un autre tableau mais ca ne marche plus, j'ai pourtant fais les modifications correspondantes, si quelqu'un peut y jeter un coup d'œil
Dans le tableau, la colonne qui m'intéresse pour la création de page est la colonne F "Stream".
Meci d'avance!

Voilà le code utilisé :

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
65
66
67
68
69
70
71
72
73
Option Compare Text
 
Function SansDoublon(Sh As Worksheet, ColonneAExtraire As Long)
' Génère une liste sans doublon des valeurs d'une colonne
' Débute en ligne 2 et s'arrête à la première ligne vide
Dim Liste, i As Long, Table()
Set Liste = CreateObject("Scripting.dictionary")
 
With Sh.Cells(4, ColonneAExtraire)
    ' on met toute la colonne dans un tableau
    Table = .Resize(.End(xlDown).Row - 1, 1).Value
 
    ' on analyse chaque valeur
    For i = LBound(Table, 1) To UBound(Table, 1)
        ' si elle n'existe pas dans le dictionnaire, on l'ajoute
        If Not Liste.exists(Table(i, 1)) Then Liste.Add Table(i, 1), Table(i, 1)
    Next i
End With
 
' si on a au moins un résultat
If Liste.Count > 0 Then
    ' on renvoie un tableau contenant les valeurs sans doublon
    SansDoublon = Application.Transpose(Liste.keys)
End If
 
End Function
 
Sub test()
Dim Tableau()
Dim ShSource As Worksheet
Dim MaColonne As Long
 
Set ShSource = ThisWorkbook.Worksheets("feuil1")
MaColonne = 6
 
' on récupère la liste sans doublon des "valeurs"
Tableau = SansDoublon(ShSource, MaColonne)
 
Application.ScreenUpdating = False
 
' pour chaque valeur
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
 
    ' on neutralise les erreurs
    On Error Resume Next
    ' on affecte la feuille à une variable + on nettoie la feuille
    Set Sh = Worksheets(Tableau(i, 1)): Sh.UsedRange.Delete
 
    ' si on a une erreur, ça veut dire que la feuille n'existe pas
    If Err.Number <> 0 Then
        ' on crée la feuille et la renomme
        Set Sh = Worksheets.Add
        Sh.Name = Tableau(i, 1)
        Err.Clear
    End If
    On Error GoTo 0
 
    ' ici, on va utiliser le filtre automatique pour exporter les données dans chaque feuille
    With ShSource
        ' désactive les filtres auto
        .AutoFilterMode = False
        ' filtre sur MaColonne pour avec "valeur" comme critère
        .Range("A1").AutoFilter MaColonne, Tableau(i, 1)
        ' on copie le résultat du filtre auto dans la feuille de "Valeurs"
        ShSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
    End With
Next i
' on enlève les filtres
ShSource.AutoFilterMode = False
 
Application.ScreenUpdating = True
 
End Sub