Optimiser le code VBA (gestion de liste)

Version imprimable

Bonjour Forum,
Pour effectuer le traitement pour toutes les autres familles existantes un tableau constitué de plusieurs variables du même type est crée. Il est composé de 4 éléments : Bois, Jardin, Décoration et Bricolage.
Ma question : dans le cas où le nombre de familles d'article dépasse 50 ou plus, comment éviter la saisie des noms en forçant une recherche dans une liste prédfinie. Il se peut que je soit dans l'erreur.

Merci par avance.

Cordialement
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub PrcVentilation() Dim ZCpt As Long Dim ZFamille As String Dim ZListeFam(4) As String ZListeFam(1) = "Bois" ZListeFam(2) = "Jardin" ZListeFam(3) = "Décoration" ZListeFam(4) = "Bricolage" Range("A4").Select Selection.AutoFilter If Dir("C:\Articles", vbDirectory) = "" Then MkDir ("C:\Articles") For ZCpt = 1 To UBound(ZListeFam) Z_Famille = UCase(ZListeFam(ZCpt)) Selection.AutoFilter Field:=1, Criteria1:=ZFamille

Une proposition si elle convient

Code:

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
Sub PrcVentilation()
Dim ZCpt As Long, NbFam As Long
Dim ZListeFam As New Collection
 
Application.ScreenUpdating = False
 
If Dir("C:\Articles", vbDirectory) = "" Then MkDir ("C:\Articles")
 
With Sheets("Feuil1")   'à adapter
    NbFam = .Cells(Rows.Count, 1).End(xlUp).Row
 
    For ZCpt = 5 To NbFam       'Données commencent en 5ème ligne
        On Error Resume Next
            .Range("A" & ZCpt) = UCase(Trim(.Range("A" & ZCpt)))
            ZListeFam.Add .Range("A" & ZCpt), .Range("A" & ZCpt)
        On Error GoTo 0
    Next ZCpt
 
    With Range("A4")
        For ZCpt = 1 To ZListeFam.Count
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=ZListeFam(ZCpt)
            '...suite code et traitement à effectuer après filtrage
        Next ZCpt
          .AutoFilter
    End With
End With
End Sub

La variable ZFAMILLE reste vide

Bonsoir Mecatog et Forum.

Merci pour ton code. Après test, la variable ZFamille reste vide. Elle doit prendre comme valeur la famille d'article de type "BRICOLAGE" pour eviter de réecrir le même fichier de nom "Articles". Le nom attendu est de type "Articles BRICOLAGE".
le code est :

Code:

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
Sub PrcVentilation_Dev()
Dim ZCpt As Long, NbFam As Long
Dim ZListeFam As New Collection
Dim ZFamille As String
 
 
Application.ScreenUpdating = False
 
If Dir("C:\Articles", vbDirectory) = "" Then MkDir ("C:\Articles")
 
With Sheets("Base")   'à adapter
    NbFam = .Cells(Rows.Count, 1).End(xlUp).Row
 
    For ZCpt = 5 To NbFam       'Données commencent en 5ème ligne
        On Error Resume Next
            .Range("A" & ZCpt) = UCase(Trim(.Range("A" & ZCpt)))
            ZListeFam.Add .Range("A" & ZCpt), .Range("A" & ZCpt)
        On Error GoTo 0
    Next ZCpt
 
    With Range("A4")
        For ZCpt = 1 To ZListeFam.Count 
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=ZListeFam(ZCpt)
 
            Selection.CurrentRegion.Select
            Selection.Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveWorkbook.SaveAs Filename:="C:\Articles\Articles" & ZFamille & ".xls"
            ActiveWorkbook.Close
            Application.CutCopyMode = False
 
        Next ZCpt
          .AutoFilter
    End With
End With
End Sub

Code:

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
Dim ZCpt As Long, NbFam As Long
Dim ZListeFam As New Collection
Dim wbk As Workbook
 
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Dir("C:\Articles", vbDirectory) = "" Then MkDir ("C:\Articles")
 
With Sheets("Base")   'à adapter
    NbFam = .Cells(Rows.Count, 1).End(xlUp).Row
 
    For ZCpt = 5 To NbFam       'Données commencent en 5ème ligne
        On Error Resume Next
            .Range("A" & ZCpt) = UCase(Trim(.Range("A" & ZCpt)))
            ZListeFam.Add .Range("A" & ZCpt), .Range("A" & ZCpt)
        On Error GoTo 0
    Next ZCpt
 
    With .Range("A4:X" & NbFam)
        For ZCpt = 1 To ZListeFam.Count
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=ZListeFam(ZCpt)
            Set wbk = Workbooks.Add(1)
            .SpecialCells(xlCellTypeVisible).Copy wbk.Sheets(1).Range("A1")
            wbk.SaveAs Filename:="C:\Articles\Articles\" & ZListeFam(ZCpt) & ".xls"
            wbk.Close
        Next ZCpt
          .AutoFilter
    End With
End With
Application.DisplayAlerts = True

09/03/2011, 01h10
BAHIRI

Code opmtimisé

Bonsoir,

Je vous remercie pour les solutions proposées et toutes mes excuses pour cette réponse tardive. Je viens de reprendre ce projet pour le clôturer.

Cordialement