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