Création Fchier Excel avec Filtre VBA

**Oulol** · 28/08/2014, 14h34

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 :

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

**SfJ5Rpw8** · 28/08/2014, 15h14

bonjour,

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

Code :

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

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 :

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

 Windows("COUTS_DETAILLES_PAR_DIRECTION.xlsm").Activate

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

Code :

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

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

par

Code :

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

  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 :

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

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

par :

Code :

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

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

**Oulol** · 28/08/2014, 15h48

Bonjour Bbil,

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

Code :

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

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,

**SfJ5Rpw8** · 28/08/2014, 15h51

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

poste ton code modifié aussi...

**Oulol** · 28/08/2014, 16h11

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

Code :

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

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

je te joins l'intégralité du 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
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

**SfJ5Rpw8** · 28/08/2014, 17h10

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 :

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

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

et le prefixe :

Code :

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

xlApp.

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

corrige la ligne Paste :

Code :

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

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

supprime toutes les lignes inutiles du genre :

Code :

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

 Windows("COUTS_DETAILLES_PAR_DIRECTION.xlsm").Activate

et reviens avec un code épuré ..

**Oulol** · 29/08/2014, 13h38

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.

**Oulol** · 29/08/2014, 14h23

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 :

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

ActiveWorkbook.SaveAs Filename

ne prend pas en compte le chemin d'enregistrement.

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

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

**mercatog** · 29/08/2014, 14h39

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

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

**Oulol** · 29/08/2014, 15h02

Bonjour Mercatog,

Je te remercie pour ce code

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

Code :

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

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

**mercatog** · 29/08/2014, 15h10

Parce que je mérite un -1

Erreur d'oubli

Code :

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

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

Edit

Remplace aussi la ligne 37 par celle là

Code :

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

Wbk.Worksheets(2).Name = "Titi"

Création Fchier Excel avec Filtre VBA

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager