Créer des fichiers Excel après un filtre sur VBA
Bonjour,
Je rencontre un petit problème avec mon code :
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
39
40
41
42
43
44
45
|
Sub Macro_Zoom()
Dim ListeTitre()
Dim ListeParam()
Dim WsSource As Worksheet
Dim WsCible As Workbook
Dim xlApp As Excel.Application
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Set WsSource = ThisWorkbook.Worksheets("Final")
ListeParam = Array("AUTO", "DAB CORPORATE", "DAB DOMESTIQUE", "DC", "NR", "RC", "TRAN")
ListeParam2 = Array("DIRECT", "EDW")
With WsSource
For i = LBound(ListeParam) To UBound(ListeParam)
For j = LBound(ListeParam2) To UBound(ListeParam2)
Set c = Nothing
Set c = .Rows(1).Find("TRAITE", , xlValues, xlWhole)
If Not c Is Nothing Then .Range("A1").AutoFilter c.Column, ListeParam(i), xlFilterValues
Set b = Nothing
Set b = .Rows(1).Find("DIRECT/EDW", , xlValues, xlWhole)
If Not b Is Nothing Then .Range("A1").AutoFilter b.Column, ListeParam2(j), xlFilterValues
ChDir "C:\Users\..."
Set xlApp = CreateObject("Excel.Application")
xlApp.SheetsInNewWorkbook = 2
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs ("ZOOM" & ListeParam(i) & ".xls")
Set xlSheet = xlBook.Sheets(j)
xlSheet.Name = "" & j
WsSource.UsedRange.Copy xlSheet.Range("A1")
Next j
Next i
End With
End Sub |
Je veux faire un filtre sur la colonne "TRAITE" (AUTO PAR Exemple) et ensuite sur la colonne "DIRECT/EDW" (DIRECT par exemple),
et ensuite dans "C:\Users\..." copier le résultat du filtre dans le classeur créé "ZOOM AUTO" et dans l'onglet DIRECT ou l'onglet EDW si le filtre "DIRECT/EDW" est sur EDW.
et Ceci pour tous les traités. Je dois donc créer un classeur par traité. J'espère que vous m'avez compris.
Je rencontre un problème avec le code déjà pour le chemin je pense et aussi pour la copie. J'ai donc besoin de votre aide. Aussi, je suis ouvert à toute proposition pour une optimisation de mon code.
Merci d'avance
Procédure qui splitte les données filtrées avec la méthode AdvnacedFilter
Bonjour,
Voici une procédure qui splitte en plusieurs feuilles regroupées au sein d'un même nouveau classeur ou en une seule feuille par nouveau classeur suivant l'arguement passé à la procédure.
Source de la procédure nommée SplitCriteriaByAdvancedFilter
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
39
40
| Sub SplitCriteriaByAdvancedFilter(areaSource As Range, LabelCriteria As String, Filter(), _
Optional IsSameWorkbook As Boolean = True)
' Exporte les données répondant aux critères vers plusieurs feuilles dans un même classeur ou plusieurs
' Author : http://philippe.tulliez.be
' Les arguments
' areaSource (Range) ' Plage contenant les données à exporter
' LabelCriteria (String) ' Nom de l'étiquette de la colonne où se trouve les données à filtrer
' Filter (Table) ' Liste contenat les critères
' [IsSameWorkbook] (Boolean) ' (True ou omis) Les feuilles sont regroupées dans un même nouveau classeur
' si False une feuille par classeur
Dim areatarget As Range, areaCriteria As Range, Elem As Integer, IsNewWorkbook As Boolean
' Définit la zone des critères 2 colonnes à droite de la zone des données (Source)
With areaSource
Set areaCriteria = .Offset(0, .Columns.Count + 1).Resize(2, 1)
End With
areaCriteria(1) = LabelCriteria ' Etiquette de la zone des critères
' Boucle sur les éléments à filtrer
For Elem = 0 To UBound(Filter)
areaCriteria(2) = Filter(Elem) ' Critère
With areaSource.Worksheet.Parent ' Classeur de la source
.Worksheets.Add before:=.Worksheets(1) ' Insère une feuille
Set areatarget = .Worksheets(1).Range("A1") ' Définit la zone d'exportatin
areatarget.Worksheet.Name = Filter(Elem) ' Renomme la feuille cible
End With
' Exportation
areaSource.AdvancedFilter xlFilterCopy, areaCriteria, areatarget
' Transfert de la feuille exportée
If IsNewWorkbook Then
With Workbooks
areatarget.Worksheet.Move before:=Workbooks(.Count).Worksheets(1)
End With
Else
areatarget.Worksheet.Move
If IsSameWorkbook Then IsNewWorkbook = True
End If
Next Elem
' Fin de procédure
areaCriteria.Clear ' Efface la zone des critères
Set areatarget = Nothing: Set areaCriteria = Nothing
End Sub |
Exemple de l'appel à cette procédure
Les données doivent être structurées selon les bonnes pratiques d'une table d'excel à savoir
- Commencer la liste de données en cellule A1
- Avoir en ligne 1, les étiquettes de colonnes sans cellules vides ni doublons
- Ne pas avoir de cellules fusionnées
- La première colonne doit être remplies de la deuxième à la dernière ligne sans avoir de lignes vides
Code:
1
2
3
4
5
6
7
8
9
10
| Sub Test()
Dim rng As Range, Criteria()
Set rng = shtData.Range("A1").CurrentRegion ' Définit la plage source (shtData est le CodeName de la feuille)
' Set rng = ThisWorkbook.Worksheets("db").Range("A1").CurrentRegion
Criteria = Array("A", "E") ' Liste des critères
Application.ScreenUpdating = False
SplitCriteriaByAdvancedFilter rng, "Dept", Criteria ' Appel de la procédure
Application.ScreenUpdating = True
Set rng = Nothing
End Sub |
La procédure a été testée plusieurs fois avec différents paramètres.
Cependant par manque de temps, il reste des améliorations à apporter comme par exemple si un critère n'existe pas la feuille sera vide et si l'étiquette de colonne de la zone des données n'existe pas la procédure se mettra en erreur et il reste à ajouter l'instruction pour sauver le ou les classeurs contenant les feuilles splittées.
