Discussion :

[aziz1015]

Bonjour,

Je rencontre un petit problème avec mon code :

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
 
 
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

[joe.levrai]

Bonjour,

il y a plusieurs problèmes en fait.

Le premier, c'est que dans ta boucle j, à chaque tour de boucle tu vas enregistrer un classeur avec le même nom.
Le second, c'est que pour chaque création de classeur, tu crées une nouvelle instance excel, ce qui est inutile est très gourmand en ressources. Tu peux directement créer un nouveau classeur dans l'instance excel où est ton classeur avec le code qui tourne.

Le troisième, accessoire, est la méthode de recherche de tes deux lignes d'en-têtes. Pourquoi n'es-tu pas certain de trouver ces deux éléments ?
(au passage, tu peux utiliser la même variable pour les détecter)

[Marc-L]

Bonjour,

le code pourrait être simplifié et donc optimisé rien qu'en utilisant le B-A-BA d'Excel,

à savoir Les filtres avancés ou élaborés dans Excel …

_________________________________________________________________________________________________________

Je suis Paris, Nice, Bruxelles, Charlie, …

[aziz1015]

Bonjour,

le code pourrait être simplifié et donc optimisé rien qu'en utilisant le B-A-BA d'Excel,

à savoir Les filtres avancés ou élaborés dans Excel …

Bonjour,

Merci pour votre aide
j'ai essayé de faire quelque chose en utilisant les filtres avancés, qu'en pensez-vous ?

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
 
 
Sub Test12()
 
Dim WsSOurce As Worksheet, filtre As Workbook, WsCible As Worksheet
Dim xlBook As Workbook
 
Set WsSOurce = ThisWorkbook.Sheets("Final")
On Error Resume Next: WsSOurce.ShowAllData: On Error GoTo 0
Application.ScreenUpdating = False
 
ListeParam = Array("AUTO", "DAB CORPORATE", "DAB DOMESTIQUE", "DC", "NR", "RC", "TRAN")
ListeParam2 = Array("DIRECT", "EDW")
 
    For i = LBound(ListeParam) To UBound(ListeParam)
        For j = LBound(ListeParam2) To UBound(ListeParam2)
            Set filtre = Workbooks.Add
            filtre.Sheets(1).Range("A1") = "TRAITE"
            filtre.Sheets(1).Range("B1") = "DIRECT/EDW"
 
            filtre.Sheets(1).Range("A2") = "=" & ListeParam(i)
            filtre.Sheets(1).Range("B2") = "=" & ListeParam2(j)
 
             ChDir "C:\Users\..."
            Set xlBook = Excel.Application.Workbooks.Add
            xlBook.SaveAs ("ZOOM" & ListeParam(i) & ".xls")
 
            Set WsCible = xlBook.Sheets(j)
            WsCible.Name = "" & ListeParam2(j)
 
            FiltreActif WsSOurce.UsedRange, filtre.Sheets(1).UsedRange, WsCible.Range("A1")
            filtre.Close False
            Set filtre = Nothing
            Set xlBook = Nothing
        Next j
    Next i
 
        Application.ScreenUpdating = True
End Sub

Cordialement

[aziz1015]

Bonjour Joe,

content de vous revoir Je ne ccomprends pas trop ce que vous voulez dire par là :

Le troisième, accessoire, est la méthode de recherche de tes deux lignes d'en-têtes. Pourquoi n'es-tu pas certain de trouver ces deux éléments ?
(au passage, tu peux utiliser la même variable pour les détecter)

Aussi, j'ai essayé de corriger en fonction de vos premières remarques, est ce cela :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
 
 
 
 ChDir "C:\Users\..."
            Set xlBook = Nothing
            Set xlBook = Excel.Application.Workbooks.Add
            xlBook.SaveAs ("ZOOM" & ListeParam(i) & ".xls")
 
            Set xlSheet = xlBook.Sheets(j)
            xlSheet.Name = "" & j
            WsSOurce.UsedRange.Copy xlSheet.Range("A1")

Merci d'avance pour votre aide

[Philippe Tulliez]

Bonjour,

j'ai essayé de faire quelque chose en utilisant les filtres avancés, qu'en pensez-vous ?

A mon avis tu n'as pas lu le tutoriel que Marc t'a référencé car tu n'utilises pas la méthode AdvancedFilter dans la procédure que tu as publiée.

[aziz1015]

Bonjour,

je me suis servi des exemples sur le filtre élaboré et j'ai essayé de coder quelque chose, je ne suis en effet pas aller jusqu'à la fin du tutoriel.

Merci

[Marc-L]

Aucun rapport avec un filtre avancé dans ton code alors à quoi bon demander ce que l'on en pense ?‼
Et puis pas besoin de notre avis s'il donne satisfaction !

Sans compter les nombreux exemples dans les discussions de ce forum comme par exemple celle-ci …

Évidemment un bête Copier/Coller d'un code trouvé sur le Net ne peut fonctionner
sans une once de jugeote pour l'adapter à son besoin.

[Philippe Tulliez]

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 :

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
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 :

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

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.

[aziz1015]

Évidemment un bête Copier/Coller d'un code trouvé sur le Net ne peut fonctionner
sans une once de jugeote pour l'adapter à son besoin.

Un bête copier/coller ? Pourriez vous rester Poli svp ? Ce code je l'ai fait moi-même il y a environ un an à l'aide de certains membres du forum qui y avaient apporté des corrections.

Cordialement

[aziz1015]

Bonjour,

il y a plusieurs problèmes en fait.

Bonjour,

Je l'ai finalement fait comme suit et ça fonctionne très bien :

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
 
 
Sub ZOOM()
 
Dim WsSource As Worksheet, filtre As Workbook, WsCible1 As Worksheet, WsCible2 As Worksheet
Dim xlBook As Workbook
 
Set WsSource = ThisWorkbook.Sheets("Final")
On Error Resume Next: WsSource.ShowAllData: On Error GoTo 0
 
 
ListeParam = Array("AUTO", "DAB CORPORATE", "DAB DOMESTIQUE", "DC", "NR", "RC", "TRAN")
 
    For i = LBound(ListeParam) To UBound(ListeParam)
            Set filtre = Workbooks.Add
            filtre.Sheets(1).Range("A1") = "TRAITE"
            filtre.Sheets(1).Range("B1") = "DIRECT/EDW"
 
            filtre.Sheets(1).Range("A2") = "" & ListeParam(i)
            filtre.Sheets(1).Range("B2") = "DIRECT"
 
            filtre.Sheets(2).Range("A1") = "TRAITE"
            filtre.Sheets(2).Range("B1") = "DIRECT/EDW"
 
            filtre.Sheets(2).Range("A2") = "" & ListeParam(i)
            filtre.Sheets(2).Range("B2") = "EDW"
 
             ChDir "P:\ZOOM"
            Application.ScreenUpdating = False
            Set xlBook = Excel.Application.Workbooks.Add
            'xlBook.SaveAs ("ZOOM " & ListeParam(i) & ".xls")
 
            Set WsCible1 = xlBook.Sheets(1)
            WsCible1.Name = "DIRECT"
 
            Set WsCible2 = xlBook.Sheets(2)
            WsCible2.Name = "EDW"
 
 
            FiltreActif WsSource.UsedRange, filtre.Sheets(1).UsedRange, WsCible1.Range("A1")
            FiltreActif WsSource.UsedRange, filtre.Sheets(2).UsedRange, WsCible2.Range("A1")
            xlBook.Close True, "ZOOM " & ListeParam(i)
            Application.ScreenUpdating = True
            filtre.Close False
            Set filtre = Nothing
            Set xlBook = Nothing
    Next i
End Sub
 
Function FiltreActif(RangeSource As Range, CriterRange As Range, CopyRange As Range, Optional Unique As Boolean = True) As Boolean
FiltreActif = False
On Error Resume Next
 RangeSource.AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=CriterRange _
        , CopyToRange:=CopyRange, Unique:=Unique
        DoEvents
        If Err = 0 Then FiltreActif = True
        'MsgBox Err.Description
        On Error GoTo 0
End Function

Merci pour vos remarques.

Cordialement