Création d'un classeurs à partir d'une selection de données.

**Tonio-** · 04/12/2014, 16h32

Bonjour,

Actuellement en stage en compta et connaissant peu le VBA je m’adresse à vous.

Nous avons une feuille des données excel regroupant plusieurs informations sur nos filiales.
J'aimerai développer une marco qui identifierai, exctracterai toutes les informations pour une filiales et créerait un classeur par filiale avec ses informations.

J'avoue être complétement perdu dans le code.

Merci pour votre aide.

Tonio-

**Gado2600** · 04/12/2014, 16h44

Bonjour

J'avoue être complétement perdu dans le code

Quel est ton code ?

identifierai, exctracterai toutes les informations

D'où proviennent les données ? Comment sont-elles organisées ?

Si c'est généré un classeur par filiale, et qu'il n'y aucun traitement à faire, l'algorithmie serait la suivante :

1) Afficher les informations avec un tri sur l'identifiant de la filiale (partie identification)
2) Parcourir chacune des lignes de ta base de données et recopier les données et/ou les traiter dans un nouveau classeur jusqu'à ce que ton identifiant ne soit plus celui qui correspond à ta filiale (partie extraction)

On manque un peu de détails...

Cordialement,

**Tonio-** · 04/12/2014, 17h06

Gado2600 merci pour ton aide.

Les données sont triées par identifiant produit. il chaque filiale possède une ou plusieurs références produits uniques.

J'ai obtenu ce code grâce à la fonction enregistrement de macro.

Je manque de connaissance pour effectuer la boucle que tu me proposes

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
Sub Test()
'
' Test Macro
'
 
' Selection des premieres données. Je ne sais pas variabiliser le "2" sachant que mes filiales vont de "01" à "99".
 
    ActiveSheet.Range("$A$2:$X$261").AutoFilter Field:=1, Criteria1:="2"
    Range("A1:Y261").Select
    Range("B7").Activate
' Copie des données et création de la nouvelle feuille
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Windows("Classeur2").Activate
'Je recommence à copier les données du même classeur, de la même filiale mais d'une autre feuille.
    ActiveSheet.Range("$A$2:$X$261").AutoFilter Field:=1
    Sheets("Produits2").Select
    Range("A118").Select
    Selection.End(xlUp).Select
    ActiveSheet.Range("$A$2:$AM$211").AutoFilter Field:=1, Criteria1:="2"
    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Classeur11").Activate
    Range("B9").Select
    Sheets("Feuil2").Select
    ActiveSheet.Paste
    Windows("Classeur2").Activate
    ActiveSheet.Range("$A$2:$AM$211").AutoFilter Field:=1
End Sub

grand merci pour ton aide.

Cordialement,

Tonio-

**MarcelG** · 04/12/2014, 17h25

Bonjour,

Tout d'abord, il faut bien débuter et nous passons tous par là.

Après une familiarisation sur les tableaux et les dictionnaires, tu pourras utiliser cette - modeste - contribution.

création de feuilles depuis occurences

Avec cette adaptation : créer un classeur en lieu et place de créer une feuille

Bonne soirée.

**Tonio-** · 05/12/2014, 17h00

Merci encore pour votre aide.

Pouvez-vous me dire vos pensées sur ce 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
62
63
 
 
Option Explicit
Option Compare Text
 
Sub Test()
 
End Sub
Dim Codeentity As String
Dim Email As String
Dim n As Integer
Dim Nom_Fichier_source As String
 
'Lancement de la boucle
n = 2
Nom_Fichier_source = ActiveWorkbook.Name
 While Not IsEmpty(Sheets("contact").Cells(n, 1))
 
 'Création et enregistrement d'un nouveau classeur
    Workbooks.Add
            ChDir "XXX/XXX/XXX/XXX"
    ActiveWorkbook.SaveAs Filename:= _
            "XXX/XXX/XXX/XXX/&n.xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
 
'Les ongles sont renommés
    ActiveSheet.Paste
        Sheets("Feuil1").Select
        Sheets("Feuil1").Name = "Product"
        Sheets("Feuil2").Select
        Sheets("Feuil2").Name = "Product bio"
 
'Selection et copie  des données
    Windows("New Product.xls").Activate
        Sheets("Bank information").Select
        ActiveSheet.Range("$A$2:$X$261").AutoFilter Field:=1, Criteria1:="n"
        Range("A1:Y261").Select
        Range("M9").Activate
        Selection.Copy
        ActiveWindow.ScrollColumn = 3
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.SmallScroll Down:=-9
 
 'Nous collons les données
    Windows("n").Activate
    ActiveSheet.Paste
 
 'Fermeture du classeur
    Windows("n.xls").Activate
    ActiveWindow.Close True
 
    n = n + 1
 
'Fin de la boucle
Wend
 
 'Nous fermons les classeurs
  Windows("New Product.xls").Activate
 ActiveWindow.Close False
 
 
End Sub

Merci pour vos retours.

Cordialement,

Tonio-

**Tonio-** · 08/12/2014, 11h21

Bonjour à tous,

Je rencontre un problème dans l'enregistrement du fichier.

Code :

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

1
2
3
4
 ActiveWorkbook.SaveAs Filename:= _
            "XXX/XXX/XXX/XXX/&n.xls", _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False

J'aimerai variabilité le nom. Savez-vous comment je peux faire ?

Cordialement,

TONIO-

Invité · 08/12/2014, 12h28

bonjour;
comme te la suggéré MarcelG, j'utiliserais un dictionnaires pour dédoublonner chaque filiale et tu utilises un filtre élaboré voir le lien!
http://www.developpez.net/forums/d13...s/#post7481714

**Tonio-** · 09/12/2014, 10h49

Bonjour rdurupt et MarcelG,

Merci beaucoup pour votre aide, mais je nage totalement.

J'ai vraiment l'impression que ce que je veux réaliser est très simple mais lors de l'activation de la marco ça ne marche pas.

De plus mon niveau est trop faible pour comprendre le vocabulaire que vous utilisez.

Merci encore pour votre aide.

Tonio-

Invité · 09/12/2014, 11h31

bonjour
Regarde le fichier joint!

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
Sub test()
Dim Dico As Object
Dim R As Range
Set R = Sheets("Feuil1").UsedRange
Set Dico = Ditionaire(R, 2, 1)
I = Dico.items
For n = 0 To Dico.Count - 1
    CreerClasseur R, "C:\MyTest", I(n)
Next
End Sub
Function Ditionaire(R As Range, lStart As Long, C As Integer) As Object
Dim L As Long
Set Ditionaire = CreateObject("Scripting.dictionary")
For L = lStart To R.Rows.Count
   If Not Ditionaire.Exists(R(L, C).Value) Then Ditionaire.Add R(L, C).Value, R(L, C).Value
Next
End Function
Sub CreerClasseur(Source As Range, Chemin, filiales)
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Dim Fltr As Workbook
Dim NewWb As Workbook
Set Fltr = Workbooks.Add
Fltr.Sheets(1).Range("A1") = "filiales"
Fltr.Sheets(1).Range("A2") = filiales
Set NewWb = Workbooks.Add
NewWb.Sheets(1).Name = filiales
FiltreActif Source, Fltr.Sheets(1).UsedRange, NewWb.Sheets(1).Range("A1"), False
Fltr.Close False
NewWb.SaveAs Chemin & filiales & ".xlsx"
NewWb.Close False
Set NewWb = Nothing
Set Fltr = Nothing
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
        On Error GoTo 0
End Function

**Tonio-** · 09/12/2014, 14h14

Rdurupt,

Ton code m'a bien aidé mais je n'arrive pas à le décortiquer pour l'adapter à mon ficher.

En effet, j'ai tenté d'adapter ce code à mon fichier, mais je bloque sur l'écriture du code pour la copie de 3 onglets par fichier.

J'ai effectué le code suivant mais cela ne marche pas

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
 
Sub CreerClasseur(Source As Range, Chemin, filiales)
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Dim Fltr As Workbook
Dim NewWb As Workbook
Set Fltr = Workbooks.Add
Fltr.Sheets(1).Range("A1") = "filiales"
Fltr.Sheets(1).Range("A2") = filiales
Fltr.Sheets(2).Range("A1") = "filiales"
Fltr.Sheets(2).Range("A2") = filiales
Fltr.Sheets(3).Range("A1") = "filiales"
Fltr.Sheets(3).Range("A2") = filiales
 
Set NewWb = Workbooks.Add
NewWb.Sheets(1).Name = filiales1
NewWb.Sheets(2).Name = filiales2
NewWb.Sheets(3).Name = filiales3
FiltreActif Source, Fltr.Sheets(1).UsedRange, NewWb.Sheets(1).Range("A1"), False
FiltreActif Source, Fltr.Sheets(2).UsedRange, NewWb.Sheets(1).Range("A1"), False
FiltreActif Source, Fltr.Sheets(3).UsedRange, NewWb.Sheets(1).Range("A1"), False
Fltr.Close False
NewWb.SaveAs Chemin & filiales & ".xlsx"
NewWb.Close False
Set NewWb = Nothing
Set Fltr = Nothing
End Sub

Merci pour le temps que vous passez

Invité · 09/12/2014, 14h28

dans l'énoncé tu parle de classeur par filiales! et là tu fais une filiale par onglet??

Code :

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

1
2
3
NewWb.Sheets(1).Name = filiales1
NewWb.Sheets(2).Name = filiales2
NewWb.Sheets(3).Name = filiales3

**Tonio-** · 09/12/2014, 14h33

Merci pour cette précision.

Non, c'est un classeur par filiale, et chaque classeur comprend 3 onglets.

Merci

Invité · 09/12/2014, 14h34

Envoyé par Tonio-

Merci pour cette précision.

Non, c'est un classeur par filiale, et chaque classeur comprend 3 onglets.

que doit-il y avoir dans ces onglet?

le dictionnaire marche pour les filiales si il y a un autre critère fixe pas besoin d'un autre si variable par apprentissage comme les filiales si.

Fltr: les valeurs sur une colonne représente un ou (OR) le valeur sur une même ligne représente un et (AND)

**Tonio-** · 09/12/2014, 14h43

C'est un classeur par filiale, et chaque classeur comprend 3 onglets.
Onglet 1 : Type de produit X.
Onglet 2 : Type de produit Y.
Onglet 3 : Type de produit Z.

Les informations se trouvent dans le fichier mère avec dans 3 onglets différents correspondants aux produits X, Y et Z.

Merci

Invité · 09/12/2014, 14h58

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
Sub CreerClasseur(Source As Range, Chemin, filiales)
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Dim Fltr As Workbook
Dim NewWb As Workbook
Set Fltr = Workbooks.Add
 
NewWb.Sheets(1).Name = filiales & " ProduitsX"
NewWb.Sheets(2).Name = filiales & " ProduitsY"
NewWb.Sheets(3).Name = filiales & " ProduitsZ"
 
Fltr.Sheets(1).Range("A1") = "filiales"
Fltr.Sheets(1).Range("A2") = filiales
Fltr.Sheets(1).Range("B1") = "Produits"
Fltr.Sheets(1).Range("B2") = "ProduitsX"
FiltreActif Source, Fltr.Sheets(1).UsedRange, NewWb.Sheets(1).Range("A1"), False
 
Fltr.Sheets(1).Range("A1") = "filiales"
Fltr.Sheets(1).Range("A2") = filiales
Fltr.Sheets(1).Range("B1") = "Produits"
Fltr.Sheets(1).Range("B2") = "ProduitsY"
FiltreActif Source, Fltr.Sheets(1).UsedRange, NewWb.Sheets(2).Range("A1"), False
 
Fltr.Sheets(1).Range("A1") = "filiales"
Fltr.Sheets(1).Range("A2") = filiales
Fltr.Sheets(1).Range("B1") = "Produits"
Fltr.Sheets(1).Range("B2") = "ProduitsZ"
FiltreActif Source, Fltr.Sheets(1).UsedRange, NewWb.Sheets(3).Range("A1"), False
 
Fltr.Close False
NewWb.SaveAs Chemin & filiales & ".xlsx"
NewWb.Close False
Set NewWb = Nothing
Set Fltr = Nothing
End Sub

**Tonio-** · 10/12/2014, 11h22

Merci Rdurupt.

Décidément je n'y arrive toujours pas.

J'ai tenté d'adapter le code à votre exemple il y a toujours l'erreur 9.filiales.xlsm

Encore merci pour votre aide.

Cordialement,

Tonio-

Invité · 10/12/2014, 11h42

Bonjour;

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
Sub test()
Dim Dico As Object
Dim R As Range
 
Set Dico = CreateObject("Scripting.dictionary")
For i = 1 To 3
Set R = Sheets(i).UsedRange
 Ditionaire R, 2, 1, Dico
 Next
i = Dico.items
For n = 0 To Dico.Count - 1
    CreerClasseur ThisWorkbook, "C:\MyTest", i(n)
Next
End Sub
Sub Ditionaire(R As Range, lStart As Long, C As Integer, Dico As Object)
Dim L As Long
For L = lStart To R.Rows.Count
   If Not Dico.Exists(R(L, C).Value) Then Dico.Add R(L, C).Value, R(L, C).Value
Next
End Sub
Sub CreerClasseur(Source As Workbook, Chemin, filiales)
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Dim Fltr As Workbook
Dim NewWb As Workbook
Set Fltr = Workbooks.Add
Fltr.Sheets(1).Range("A1") = "filiales"
Fltr.Sheets(1).Range("A2") = filiales
Set NewWb = Workbooks.Add
For i = 1 To 3
    NewWb.Sheets(i).Name = Source.Sheets(i).Name
FiltreActif Source.Sheets(i).UsedRange, Fltr.Sheets(1).UsedRange, NewWb.Sheets(i).Range("A1"), False
Next
Fltr.Close False
NewWb.SaveAs Chemin & filiales & ".xlsx"
NewWb.Close False
Set NewWb = Nothing
Set Fltr = Nothing
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
        On Error GoTo 0
End Function

**Tonio-** · 15/12/2014, 13h59

Ca marche,
grand merci à tous.

Création d'un classeurs à partir d'une selection de données. [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager