Création Fchier Excel avec Filtre VBA

Version imprimable

Bonjourà vous et merci de votre présence.

Je me tire les cheveux depuis hier sur une ligne de programme qui en théorie ne me paraissait pas compliquée.
Je vous explique plus concrétement, j'ai crée une macro permettant de créer autant de fichiers Excel qu'il y a de directions (Onglet Liste_Direction)

La création de ces fichiers se déroule correctement mais au moment de réactiver le classeur nouvellement crée le code erreur 9 apparait.
La ligne de commande qui ressort est celle-ci: Workbooks(Nom_Fichier).Activate

~~Je vous joins également l'intégralité du code et la fichier en question.~~

Je vous remercie beaucoup pour les olutions que vous pourrez m'apporter.

Bonne journée à vous

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
 
Sub MAJ()
 
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim Nom_Fichier As Variant
Dim Extention As Variant
Dim Nom_direction As Variant
Dim finfeuille As Variant
Dim Fin_Direction As Variant
Dim i As Integer
Dim wbMyWb As Workbook
 
 
 
' Filtre Direction
 
Fin_Direction = Feuil6.Range("a1").End(xlDown).Row
 
For i = 2 To Fin_Direction
Range("$A$1:$L$65000").AutoFilter Field:=1, Criteria1:=Feuil6.Range("a" & Fin_Direction)
 
' Export et copie des fichiers
 
 Nom_direction = "COUTS_DETAILLES_" & Feuil6.Range("a" & Fin_Direction).Value
 Extention = ".xlsx"
 Nom_Fichier = Nom_direction + Extention
 
    ''On créer l'objet Excel
    Set xlApp = CreateObject("Excel.Application")
    ''On défini le nombre d'onglets (ici 2)
    xlApp.SheetsInNewWorkbook = 2
    ''On ajoute un classeur
    Set xlBook = xlApp.Workbooks.Add
    ''On donne un nom au classeur
    xlBook.SaveAs ("N:\DAPE\3 DCGS\CANA\3- Suivi Enveloppes\09-2014\EXTRACTION_COUTS_DETAILLES\EXPORTS_COUTS_DETAILLES\" & Nom_direction)
    ''On rend le classeur visible
    xlApp.Visible = True
    ''On créer l'objet onglet dans le nouveau classeur créé
    Set xlSheet = xlBook.Worksheets(1)
    ''On affecte un nom aux l'onglets
    xlSheet.Name = "COUTS_DETAILLES"
    ''on libère l'objet onglet pour pouvoir en créer un nouveau ... etc
    Set xlSheet = Nothing
        Set xlSheet = xlBook.Worksheets(2)
    xlSheet.Name = "ANALYSES-COMMENTAIRES"
 
  Windows("COUTS_DETAILLES_PAR_DIRECTION.xlsm").Activate
  Feuil4.Range("a1:l65000").Copy
 
 Workbooks(Nom_Fichier).Activate
 
  Sheets("COUTS_DETAILLES").Activate
  Range("a2").Paste
 
Next
 
End Sub

28/08/2014, 15h14
SfJ5Rpw8
bonjour,

tout d'abords pourquoi créer une nouvelle instance d'excel ???

Code:

Set xlApp = CreateObject("Excel.Application")

si ton code s’exécute sous excel tu peu utiliser l'application courante et donc tu n'as pas besoin d'objet xlApp supplémentaire... ?

ensuite c'est quoi cela :

Code:

Windows("COUTS_DETAILLES_PAR_DIRECTION.xlsm").Activate

ce xlsm est-il celui contenant ton code ? si oui remplace :
Code:

1 2 Windows("COUTS_DETAILLES_PAR_DIRECTION.xlsm").Activate Feuil4.Range("a1:l65000").Copy
par

Code:

ThisWorkbook.Feuil4.Range("a1:l65000").Copy

tu n'as pas besoin d'active un classeur pour effecteur une copie ou autre .... en général il faut éviter les instructions : Select, Selection , Activate , Active ...

tu as un objet workbook qui pointe vers ton fichier "Nom_fichier" remplacde
Code:

1 2 3 4 Workbooks(Nom_Fichier).Activate Sheets("COUTS_DETAILLES").Activate Range("a2").Paste
par :

Code:

xlBook.Sheets("COUTS_DETAILLES").Range("a2").Paste
28/08/2014, 15h48
Oulol

Bonjour Bbil,

Je te remercie pour la réponse mais le code ne s'exute toujours pas il s'arrete sur cette ligne

Code:

xlBook.Sheets("COUTS_DETAILLES").Range("a2").Paste

Oui en effet mon Xlsm "COUTS_DETAILLES_PAR_DIRECTION.xlsm" est bien mon fchier qui contient la macro et l'intégralité des données.
C'est sur ce fichier que je souhaite filtrer les données d'autant de fois que je possède directions et de créer autant de fichiers Excel.

Merci encore,
28/08/2014, 15h51
SfJ5Rpw8

et c'est quoi qui te fait dire que le code s'arrête la ...?

poste ton code modifié aussi...

Le code erreur execution 438 s'affiche et plante à la ligne

Code:

xlBook.Sheets("COUTS_DETAILLES").Range("a2").Paste

je te joins l'intégralité du 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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Option Explicit
 
Sub MAJ()
 
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim Nom_Fichier As Variant
Dim Extention As Variant
Dim Nom_direction As Variant
Dim finfeuille As Variant
Dim Fin_Direction As Variant
Dim i As Integer
Dim wbMyWb As Workbook
 
 
 
' Filtre Direction
 
Fin_Direction = Feuil6.Range("a1").End(xlDown).Row
 
For i = 2 To Fin_Direction
Range("$A$1:$L$65000").AutoFilter Field:=1, Criteria1:=Feuil6.Range("a" & Fin_Direction)
 
' Export et copie des fichiers
 
 Nom_direction = "COUTS_DETAILLES_" & Feuil6.Range("a" & Fin_Direction).Value
 Extention = ".xlsx"
 Nom_Fichier = Nom_direction + Extention
 
    ''On créer l'objet Excel
    Set xlApp = CreateObject("Excel.Application")
    ''On défini le nombre d'onglets (ici 2)
    xlApp.SheetsInNewWorkbook = 2
    ''On ajoute un classeur
    Set xlBook = xlApp.Workbooks.Add
    ''On donne un nom au classeur
    xlBook.SaveAs ("N:\DAPE\3 DCGS\CANA\3- Suivi Enveloppes\09-2014\EXTRACTION_COUTS_DETAILLES\EXPORTS_COUTS_DETAILLES\" & Nom_direction)
    ''On rend le classeur visible
    xlApp.Visible = True
    ''On créer l'objet onglet dans le nouveau classeur créé
    Set xlSheet = xlBook.Worksheets(1)
    ''On affecte un nom aux l'onglets
    xlSheet.Name = "COUTS_DETAILLES"
    ''on libère l'objet onglet pour pouvoir en créer un nouveau ... etc
    Set xlSheet = Nothing
        Set xlSheet = xlBook.Worksheets(2)
    xlSheet.Name = "ANALYSES-COMMENTAIRES"
 
  Windows("COUTS_DETAILLES_PAR_DIRECTION.xlsm").Activate
  Feuil4.Range("a1:l65000").Copy
 'ThisWorkbook.Feuil4.Range("a1:l65000").Copy
 
 
'Workbooks(Nom_Fichier).Activate
xlBook.Sheets("COUTS_DETAILLES").Range("a2").Paste
 
 
Next
 
End Sub

Merci encore

28/08/2014, 17h10
SfJ5Rpw8
on vas faire pas à pas ...

tu ne m'as pas répondu tu semble pas avoir besoin de plusieurs instance d'excel ...

supprime les lignes :
Code:

1 2 3 4 5 Dim xlApp As Excel.Application Set xlApp = CreateObject("Excel.Application")
et le prefixe :

Code:

xlApp.

afin qu'excel utilise le prefixe Application par défaut (l'application courante) .

corrige la ligne Paste :

Code:

xlBook.Sheets("COUTS_DETAILLES").Paste xlBook.Sheets("COUTS_DETAILLES").Range("a2")

supprime toutes les lignes inutiles du genre :

Code:

Windows("COUTS_DETAILLES_PAR_DIRECTION.xlsm").Activate

et reviens avec un code épuré ..
29/08/2014, 13h38
Oulol

Créaation Fchier Excel avec Filtre VBA

Bonjour à tous et tout d'abord merci pour votre présence.
Depuis avant hier je me tire les cheveux sur un programme qui me semblait à première vue pas si compliqué que ça.

Je m'explique plus en détail:

Je dispose d'un classeur Excel comportant deux onglets principaux:

Onglet n°1: Base de donnée indiquant les coûts détaillés plusieurs directions. (Onglet EXTRACT_KE5Z)
Onglet n°2: Liste des directions. (Onglet LISTE_DIRECTION)

Avec ces informations je souhaite filtrer dans la base de donnée (Onglet n°1) et créer un nouveau classeur Excel, le nommer avec le code direction concerné et coller uniquement les données filtrées de la direction concernée.
Je souhaiterais également rajouter automatiquement l'onglet "ANALYSES-COMMENTAIRES"
Pour ce faire j'ai donc créé une boucle qui devait faire le travail.

Si vous pouviez me venir en aide cela serait super et me permettrait de gagner un temps énorme.

Je vous remercie par avance pour votre aide.

Création Fichier Xls automatiquement Variable

Re Bonjour Bbil,

Me voici revenu avec, je pense, un code plus épuré.
J'ai trouvé la solution de filtré sur le code direction et de faire des Enregistrer sous en reprenant le nom de la direction.

Je n'arrive pas à faire deux choses.

1) Les données sont justes filtrées et je ne dispose pas uniquement des données de la direction sélectionnée à l'aide de la boucle dans le classeur nouvellement créé.

2) La fonction

Code:

ActiveWorkbook.SaveAs Filename

ne prend pas en compte le chemin d'enregistrement.

Je vous joins le code modifié et vous rermercie encore.

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
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub MAJMODULE3()
 
 
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim Nom_Fichier As Variant
Dim chemin As Variant
Dim Extention As Variant
Dim Nom_direction As Variant
Dim finfeuille As Variant
Dim Fin_Direction As Variant
Dim i As Integer
Dim wbMyWb As Workbook
 
 
'Alignement des directions
 
Feuil4.Activate
finfeuille = Range("c1").End(xlDown).Row
Range("a2").FormulaLocal = "=RECHERCHEV(E2;'BASE-CC_DIRECTION'!A:F;3;0)"
Range("a2").Copy
Range("a2:a" & finfeuille).PasteSpecial Paste:=xlPasteFormulas
Range("a2:a" & finfeuille).Copy
Range("a2:a" & finfeuille).PasteSpecial xlPasteValues
Application.CutCopyMode = False
 
 
 
'Alignement des enveloppes
 
finfeuille = Range("c1").End(xlDown).Row
Range("b2").FormulaLocal = "=RECHERCHEV(F2;'BASE_NATURE-ENVELOPPE'!A:B;2;0)"
Range("b2").Copy
Range("b2:b" & finfeuille).PasteSpecial Paste:=xlPasteFormulas
Range("b2:b" & finfeuille).Copy
Range("b2:b" & finfeuille).PasteSpecial xlPasteValues
Application.CutCopyMode = False
 
' Filtre Direction
 
Fin_Direction = Feuil6.Range("a1").End(xlDown).Row
 
For i = 2 To Fin_Direction
Range("$A$1:$L$65000").AutoFilter Field:=1, Criteria1:=Feuil6.Range("a" & i)
 
' Export et copie des fichiers
 
 Nom_direction = "COUTS_DETAILLES_" & Feuil6.Range("a" & i).Value
 
 chemin = ThisWorkbook.Path
 
 ActiveWorkbook.SaveAs Filename:=chemin & Nom_direction & ".xls"
 
 
 
Next
 
End Sub

Merci encore

Sans tester, regarde le code avec en particulier les déclarations des variables et éventuellement avec un débogage pas à pas (F8)

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
46
47
Sub MAJMODULE3()
Dim FinFeuille As Long, Fin_Direction As Long, i As Long
Dim Direction As String, Chemin As String
Dim Wbk As Workbook
Dim N As Byte
 
 
Application.ScreenUpdating = False
N = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 2
 
With Feuil4
    .AutoFilterMode = False
    FinFeuille = .Cells(.Rows.Count, "C").End(xlUp).Row
    With .Range("A2:A" & FinFeuille)
        .Formula = "=VLOOKUP($E2,'BASE-CC_DIRECTION'!$A:$C,3,0)"
        .Value = .Value
    End With
    With .Range("B2:B" & FinFeuille)
        .Formula = "=VLOOKUP($F2;'BASE_NATURE-ENVELOPPE'!$A:$B;2;0)"
        .Value = .Value
    End With
 
    Chemin = ThisWorkbook.Path
    Fin_Direction = Feuil6.Cells(Feuil6.Rows.Count, "A").End(xlUp).Row
 
    For i = 2 To Fin_Direction
        Direction = Feuil6.Range("a" & i)
        .Range("A1:L" & FinFeuille).AutoFilter Field:=1, Criteria1:=Direction
 
        Set Wbk = Workbooks.Add
        Wbk.Worksheets(1).Name = "Toto"
 
        .Range("A1:L" & FinFeuille).SpecialCells(xlCellTypeVisible).Copy Wbk.Worksheets(1)
        .AutoFilterMode = False
 
        Wbk.Worksheets(1).Name = "Titi"
 
        Application.DisplayAlerts = False
        Wbk.SaveAs Filename:=Chemin & "\COUTS_DETAILLES_" & Direction
        Application.DisplayAlerts = True
        Wbk.Close False
        Set Wbk = Nothing
    Next i
End With
Application.SheetsInNewWorkbook = N
End Sub

29/08/2014, 15h02
Oulol

1 pièce(s) jointe(s)

Bonjour Mercatog,

Je te remercie pour ce code

J'ai modifé une ligne de formule et le code s'arrete à la ligne

Code:

.Range("A1:L" & FinFeuille).SpecialCells(xlCellTypeVisible).Copy Wbk.Worksheets(1)

En fait je souhaite copier les données du classeur d'origine vers le classeur nouvellement créé.

Mais à part çà ca à l'air d'etre bien avancé..

Je te joins le fichier. Je profite de tes compétences pour demander également si il serait possible d'ajouter automatiquement à tous les fichiers Excel nouvellement créé l'onglet "ANALYSES-COMMENTAIRES"

Merci encore par avance,
29/08/2014, 15h10
mercatog

Parce que je mérite un -1

Erreur d'oubli

Code:

.Range("A1:L" & FinFeuille).SpecialCells(xlCellTypeVisible).Copy Wbk.Worksheets(1).Range("A1")

Edit

Remplace aussi la ligne 37 par celle là

Code:

Wbk.Worksheets(2).Name = "Titi"
29/08/2014, 15h36
Oulol

Super Mercatog . Je te remercie cela fonctionne très bien.

Puis je juste te demander une ligne de commande supplémentaire pour copier l'onglet ANALYSES-COMMENTAIRES dans tous les nouveaux classeurs créés

Merci par avance, tu es top 8-)

Tu dois chercher la solution de toi même, tu as l'enregistreur de macro qui aide énormément.

Pour cette fois:

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
Sub MAJMODULE3()
Dim FinFeuille As Long, Fin_Direction As Long, i As Long
Dim Direction As String, Chemin As String
Dim Wbk As Workbook
 
Application.ScreenUpdating = False
With Feuil4
    .AutoFilterMode = False
    FinFeuille = .Cells(.Rows.Count, "C").End(xlUp).Row
    With .Range("A2:A" & FinFeuille)
        .Formula = "=VLOOKUP($E2,'BASE-CC_DIRECTION'!$A:$C,3,0)"
        .Value = .Value
    End With
    With .Range("B2:B" & FinFeuille)
        .Formula = "=VLOOKUP($F2,'BASE_NATURE-ENVELOPPE'!$A:$B,2,0)"
        .Value = .Value
    End With
 
    Chemin = ThisWorkbook.Path
    Fin_Direction = Feuil6.Cells(Feuil6.Rows.Count, "A").End(xlUp).Row
 
    For i = 2 To Fin_Direction
        Direction = Feuil6.Range("a" & i)
        .Range("A1:L" & FinFeuille).AutoFilter Field:=1, Criteria1:=Direction
 
        Set Wbk = Workbooks.Add
        Wbk.Worksheets(1).Name = "Toto"
 
        .Range("A1:L" & FinFeuille).SpecialCells(xlCellTypeVisible).Copy Wbk.Worksheets(1).Range("A1")
        .AutoFilterMode = False
 
        ThisWorkbook.Worksheets("ANALYSES-COMMENTAIRES").Copy After:=Wbk.Worksheets(1)
 
        Application.DisplayAlerts = False
        Wbk.SaveAs Filename:=Chemin & "\COUTS_DETAILLES_" & Direction
        Application.DisplayAlerts = True
        Wbk.Close False
        Set Wbk = Nothing
    Next i
End With
End Sub

29/08/2014, 16h15
Oulol

Super Merci cela fonctionne nickel

Oui désolé. J'avoue que tu m'as un peu perdu au final.. Mais cela fonctionne nickel et je saurai le refaire ;)