Filtre selon les modalités d'une colonne

**doncamelo** · 27/10/2009, 10h13

Bonjour tout le monde,

J'aimerais avoir votre avis sur le code ci-dessous.
J'ai récupéré quelques codes après avoir fais le tour du forum et des tutos VB Excel, mais là je suis dépassé.

Voici ma tâche :

Dans une fichier, j'ai des informations sur des clients.
Je dois créer un classeur excel par départements pour tous les clients désireux de recevoir un courrier.

la colonne "Dept" contient les N° de département (38, 69, 77, 91 etc ....) et la colonne "courrier" contient la réponse des clients (cellule vide ou "oui").
Le classeur devras être enregistré sous le format "Client_N°Dept_AnneeMoisJour".

Ma démarche de novice :

1- Faire la copie de la base sur une autre feuille nommée "Base1"
2- Supprimer toutes les lignes vides de la colonne "Courrier" pour avoir que les "oui"
3- Copier la feuille "Base1" sur une feuille nommée "Base2",
puis créer une colonne "SansDoublons" pour avoir les départements distincts.
4- Affecter une variable range à la plage de données "SansDoublons",
puis pour chaque valeur de la plage, j'effectue un filtre, ensuite j'enregistre le résultat dans un classeur au format demandé.

Manuellement ça marche pour un temps fou.
Avec VB ce n'est pas le cas.

Mon code va choquer les experts, mais c'est ce qui m'est venu en tête.
Pourriez-vous m'expliquer ce qui ne va pas avec mon code et/ou me proposer autre chose?

Merci beaucoup pour votre aide

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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
Sub Ventillation()
 
' On vérifie l'existance du répertoire C:\TEST\Ventillation sinon on le crée
    If Dir("C:\TEST", vbDirectory) = "" Then MkDir ("C:\TEST")
    If Dir("C:\TEST\Ventillation", vbDirectory) = "" Then MkDir ("C:\TEST\Ventillation")
 
' On vérifie l'existance des feuilles intermédiaires
    Dim Ws As Worksheet
    Application.DisplayAlerts = False
 
        For Each Ws In ActiveWorkbook.Worksheets
            If Ws.Name = "Base1" Then
            Ws.Delete
            Exit For
        End If
        Next
 
        For Each Ws In ActiveWorkbook.Worksheets
            If Ws.Name = "Base2" Then
            Ws.Delete
            Exit For
        End If
        Next
 
    Sheets("Base").Select
    Sheets("Base").Copy After:=Sheets(Sheets.Count)
    Sheets("Base (2)").Select
    Sheets("Base (2)").Name = "Base1"
 
    'On supprime les modalités <> "oui" de la colonne "Courrier"
    Sheets("Base1").Select
    derniereLigne = ActiveSheet.UsedRange.Rows.Count
    Application.ScreenUpdating = False
        For r = derniereLigne To 5 Step -1
            If Cells(r, 11) <> "oui" Then Rows(r).Delete
        Next r
 
    Sheets("Base1").Select
    Sheets("Base1").Copy After:=Sheets(Sheets.Count)
    Sheets("Base1 (2)").Select
    Sheets("Base1 (2)").Name = "Base2"
 
    Sheets("Base2").Select
 
    'On trie selon les Dept dans l'ordre décroissant
    NbEnreg = Range("A5").End(xlDown).Row
    Range(Cells(4, 1), Cells(NbEnreg, 11)).Select
    Selection.Sort Key1:=Range("F5"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortTextAsNumbers
 
    'On récupère les Dept sans doublons
    Cells(4, 12).Value = "SansDoublons"
    Cells(5, 12).Value = Cells(5, 6).Value
    Cells(6, 12).Value = "=IF(RC[-6]<>R[-1]C[-6],RC[-6],"""")"
    Cells(6, 12).Select
    Selection.AutoFill Destination:=Range(Cells(6, 12), Cells(NbEnreg, 12)), Type:=xlFillDefault
    ActiveWorkbook.Save
 
    'On enlève les formules
    Range(Cells(5, 12), Cells(NbEnreg, 12)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Save
 
    'On ventille
    Dim plage As Range
    Dim cell As Range
    Dim i As Integer
    Set plage = Sheets("Base2").Range(Cells(5, 12), Cells(NbEnreg, 12))
 
 
        For Each cell In plage
            If cell <> "" Then
                Sheets("Base1").Select
                Range("A4:K4").Select
                Selection.AutoFilter
                Selection.AutoFilter Field:=6, Criteria1:=cell
                Cells.Select
                Cells.Copy
                Workbooks.Add
                ActiveSheet.Paste
                ActiveWorkbook.SaveAs Filename:="C:\TEST\Ventillation" & cell & ".xls"
                ActiveWorkbook.Close
                Application.CutCopyMode = False
            End If
 
        Next cell
    Selection.AutoFilter
 
End Sub

**Fvandermeulen** · 27/10/2009, 12h37

Salut Doncamelo,
Pour commencer, peux-tu, lorsque tu mets du code dans le Post le délimiter? Pour ça tu sélectionne le texte qui compose ton code et tu click sur #, c'est plus facile à lire.
Je t'avoue ne pas m'être attaqué à ton code, car selon ce que tu explique un Tableau Croisé Dynamique devrait répondre à ton problème.

Sinon, essaie avec les filtres avancés, tu peux copier le résultat en ne gardant que les lignes uniques.

Par contre si tu veux absolument passer par du code, dis le et on regardera ton code de plus près.

A+

**doncamelo** · 28/10/2009, 02h42

Bonjour Fvandermeulen,

Merci de t'être penché sur mon problème.

En faite, j'effectue le traitement avec plusieurs méthodes : TCD, filtre élaboré ou filtre simple. Tout dépend du nombre de client que contient le fichier.

Dans la mesure où c'est un traitement hebdomadaire, j'ai donc pensé à automatiser.
Quelque soit la méthode utilisée, mon soucis reste le même, pouvoir récupérer les valeurs distincts de la colonne "Dept" afin de les passer en boucle.

En ce moment, je me penche sur les tableaux vba.

Merci pour tes conseils.

**Fvandermeulen** · 29/10/2009, 09h18

Re,
En effet, les tablo peuvent être une solution, vas voir aussi dans les tutos et FAQ pour les doublons (ou fait une recherche), désolé de ne pas avoir quelque chose de plus précis mais j'avoue avoir du mal à visualiser ton fichier...
Par contre si tu coince sur un truc précis dans la suite de ta procédure, n'hésite pas.
A+

**doncamelo** · 30/10/2009, 19h51

Bonsoir Fvandermeulen,

Après quelques recherches sur les FAQ et sur le forum Excel pour trouver des infos sur les tableaux vba, j'ai pu mettre en place mon code qui fonctionne.

Mais je pense qu'il peut être amélioré, mais vraiment plus.

Peux-tu y jetter un coup d'oeil s'il te plait ?
En pièce jointe tu trouveras un fichier exemple.

Merci encore pour ton aide.

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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
Sub Ventillation()
 
    'Suppression des alertes et autres
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
 
    Dim Ws As Worksheet
        For Each Ws In ActiveWorkbook.Worksheets
            If Ws.Name = "Base1" Then
            Ws.Delete
            Exit For
        End If
        Next
 
        For Each Ws In ActiveWorkbook.Worksheets
            If Ws.Name = "Base2" Then
            Ws.Delete
            Exit For
        End If
        Next
 
    'On copie la feuille "Base"
    Sheets("Base").Select
    Sheets("Base").Copy After:=Sheets(Sheets.Count)
    Sheets("Base (2)").Select
    Sheets("Base (2)").Name = "Base1"
 
        Sheets("Base1").Select
 
    'On supprime les modalités <> "oui" de la colonne "Courrier"
    Sheets("Base1").Select
    derniereLigne = ActiveSheet.UsedRange.Rows.Count
        For r = derniereLigne To 5 Step -1
            If Cells(r, 11) <> "oui" Then Rows(r).Delete
        Next r
 
    'On trie selon les Dept dans l'ordre décroissant
    NbEnreg = Range("A5").End(xlDown).Row
    Range(Cells(4, 1), Cells(NbEnreg, 11)).Select
    Selection.Sort Key1:=Range("F5"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortTextAsNumbers
 
    'On copie la feuille "Base1"
    Sheets("Base1").Select
    Sheets("Base1").Copy After:=Sheets(Sheets.Count)
    Sheets("Base1 (2)").Select
    Sheets("Base1 (2)").Name = "Base2"
 
    Sheets("Base2").Select
 
    'On récupère les zones sans doublons
    Cells(4, 12).Value = "SansDoublons"
    Cells(5, 12).Value = Cells(5, 6).Value
    Cells(6, 12).Value = "=IF(RC[-6]<>R[-1]C[-6],VALUE(RC[-6]),"""")"
    Cells(6, 12).Select
    Selection.AutoFill Destination:=Range(Cells(6, 12), Cells(NbEnreg, 12)), Type:=xlFillDefault
    ActiveWorkbook.Save
 
    'On enlève les formules
    Columns("L:L").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
 
    'On supprime le cellules = 0 dans la colonne "SansDoublons" SUR 200 LIGNES
    limite = 200
    Dim cellule As Range
    Range(Cells(6, 12), Cells(limite, 12)).Select
        For Each cellule In Selection
            If cellule = 0 Then cellule.Delete
        Next cellule
 
 
    'On ne garde que la plage des sans doublons
    Rows("1:3").Delete
        For r = limite To 5 Step -1
            If Cells(r, 12) = "" Then Rows(r).Delete
        Next r
    Columns("A:K").Delete
 
    'On enregistre les cellules non vide de la colonne "SansDoublons" dans un tableau
     Dim plage As Range
     Dim i As Integer
     Dim Departement() As Integer
 
     Set plage = Worksheets("Base2").Range(Cells(2, 1), Cells(limite, 1))
 
    Sheets("Base1").Select
 
    Range("A4:K4").Select
    Selection.AutoFilter
 
' On vérifie l'existance du répertoire C:\TEST\Ventillation sinon on le crée
    If Dir("C:\TEST", vbDirectory) = "" Then MkDir ("C:\TEST")
    If Dir("C:\TEST\Ventillation", vbDirectory) = "" Then MkDir ("C:\TEST\Ventillation")
 
        For Each cellule In plage
    If cellule <> "" Then
            i = i + 1
            ReDim Preserve Departement(i)
            Departement(i) = cellule.Value
 
            Selection.AutoFilter Field:=6, Criteria1:=Departement(i)
            Cells.Select
            Cells.Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveWorkbook.SaveAs Filename:="C:\TEST\Ventillation\Clients du " & Departement(i) & "_" & Year(Now()) & Month(Now()) & Day(Now()) & ".xls"
            ActiveWorkbook.Close
            Application.CutCopyMode = False
        End If
        Next cellule
 
    Selection.AutoFilter
 
'On supprime les feuilles intermédiaires
        For Each Ws In ActiveWorkbook.Worksheets
            If Ws.Name = "Base1" Then
                Ws.Delete
                Exit For
            End If
        Next
 
        For Each Ws In ActiveWorkbook.Worksheets
            If Ws.Name = "Base2" Then
                Ws.Delete
                Exit For
            End If
        Next
 
' Réactivation des alertes et autres
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
End Sub

**Fvandermeulen** · 03/11/2009, 09h03

Salut,
Je n'ai pas ouvert ton fichier mais regardé ton code, tu as encore la possibilité d'améliorer deux trois points, mais en tout cas bravo pour le boulot, c'est agréable de voir des gens qui cherche vraiment sans attendre un code tout prêt

Au début du code tu ballaie toutes les feuilles pour en supprimer Base1 ou Base2, la première question à ce poser, est-ce que ces feuilles vont toujours exister au lancement de la macro, si oui le For Each est inutile.
Sinon tu peux regrouper le test en faisant:

Code :

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

1
2
3
4
    Dim Ws As Worksheet
        For Each Ws In ActiveWorkbook.Worksheets
            If Ws.Name = "Base1" or Ws.name = "Base2" Then Ws.Delete
        Next

Un autre principe dans le codage, éviter les Select, bien que tu aies bloqué le Screenupdating le Select va ralentir ta macro. Par exemple, pour copier ta feuille Base et la renommer ces deux lignes sont suffisantes:

Code :

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

1
2
3
    'On copie la feuille "Base"
    Sheets("Base").Copy After:=Sheets(Sheets.Count)
    Sheets("Base (2)").Name = "Base1"

Dans ta suppression de Oui, bien que tu sélectionne la bonne feuille au début, je te conseille de toujours indiquer la nom de la feuille sur laquelle tu teste, j'aurais écrit:

Code :

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

1
2
3
4
5
    'On supprime les modalités <> "oui" de la colonne "Courrier"
    derniereLigne = Sheets("Base1").UsedRange.Rows.Count
        For r = derniereLigne To 5 Step -1
            If Sheets("Base1").Cells(r, 11) <> "oui" Then Sheets("Base1").Rows(r).Delete
        Next r

J'ai aussi un gros doute sur la ligne ci-dessous

Code :

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

Cells(6, 12).Value = "=IF(RC[-6]<>R[-1]C[-6],VALUE(RC[-6]),"""")"

As tu le résultat souhaité ?
Je te conseille de faire le teste en VBA au lieu de faire une formule et la copier (ça réduira la taille de ton fichier)
Ca donnerait:

Code :

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

1
2
3
    For r = 5 To derniereLigne
        If Sheets("Base2").Cells(r, 12) <> Sheets("Base2").Cells(r - 1, 12) Then Sheets("Base2").Cells(r, 12) = Sheets("Base2").Cells(r, 6)
    Next r

Du coup la partie ou tu fais un copier/coller Valeur est inutile

Je n'ai pas bien compris la partie où tu supprime les 0 sur 200 lignes, est-ce absolument nécessaire ? Ne peux tu pas le coupler avec le controle suivant qui supprime les vides.
Si tu supprime les vides et/ou les 0 tu peux écrire:

Code :

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

If sheets("Base2").Cells(r, 12) = "" or sheets("Base2").cells(r,12)=0 Then Rows(r).Delete

Voilà, j'espère que ces quelques remarques vont t'être utiles.

A+

Filtre selon les modalités d'une colonne [XL-2003]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager