Discussion :

[PinkPanthere]

Bonsoir tout le monde,

Je viens ici en quête d'aide après avoir en vain tenté de me débrouillée seule.
Je suis souvent tombée sur ce forum en faisant mes recherches mais hélas je n'ai pas trouvé les réponses à mon problème particulier donc le voici si vous voulez bien :

Mon patron m'a donné un classeur avec deux feuilles :

feuille datas : une liste énorme de produits
feuille liste : liste de fournisseurs

Et je dois créer un nouveau fichier excel pour chaque fournisseurs de la liste2 listant tout ses produit de la liste1
LE tout en gardant la même mise en page et en nommant le fichier avec le nom du client.
J'ai fait manuellement un temps puis j'ai cherché à automatiser.


J'ai déjà une partie du code qui consiste à copier/coller puis sauvegarder avec le nom qui va bien que voici :

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
 
    Sub macro1()
 
 
    'copicolle
 
    Range(Sheets("Datas").Rows("3"), Sheets("Datas").Rows("3").End(xlDown)).Select
    Range(Selection, Selection.End(xlUp)).Copy
 
    Workbooks.Add
    Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
 
 
    'sauvegarde
    Range("A1").Select
    nom = Cells(4, 3)
    ActiveWorkbook.SaveAs Filename:="FICHIER_REPONSE_" & nom & ".xlsx"
    ActiveWindow.Close
 
 
    End Sub

Mais je dois encore filtrer a chaque fois manuellement en rentrant la reférence du fournisseur dans la liste énorme de produits puis je lance ma macro qui copie/colle et sauvegarde et je rentre la référence suivante.
Il me reste encore 7000 référence à faire alors il me faut absolument un moyen d'automatiser car je suis persuadée que c'est possible mais jusque là un vrais casse tête.
J'ai tenté de me renseigné sur les boucles et les filtres mais deux feuilles ça complique je désespère.

Voila, donc merci d'avance a ceux qui prendraient le temps de m'aider



Edit: rajouté les balises CODE, merci Igloobel c'est vrai que c'est mieux ^^

[Igloobel]

Bonsoir,

tu dis

Mon patron m'a donné un classeur avec deux feuilles :

feuille datas : une liste énorme de produits
feuille liste : liste de fournisseurs

Ah oui, je vois ça d'ici !!!

Et je dois créer un nouveau fichier excel pour chaque fournisseurs de la liste2 listant tout ses produit de la liste1
LE tout en gardant la même mise en page et en nommant le fichier avec le nom du client.

Le coup classique j'ai déjà vécu un truc du même genre !

J'ai fait manuellement un temps ...

Mon dieu quel courage !

... puis j'ai cherché à automatiser

Très bonne idée !

... il me faut absolument un moyen d'automatiser car je suis persuadée que c'est possible ...

Cent fois oui c'est possible !!!

Bon ta demande n'est pas très compliqué
Par contre j'ai besoin de précisions
- tes 7000 références c'est des références fournisseurs ou produits ?
- As-tu pensé a trié tes feuilles
feuille datas : par références fournisseurs puis par références Produits
feuille liste : par références Produits

cela simplifiera la création de ta macro

Si tu peux mettre un petit classeur sans données semble (un extrait) ce serai bien plus simple pour nous.

N’oublies pas de cliquer sur le bouton # quand tu crées un post cela ouvre des balises CODE .
Tu mets ton code entre ces balises pour que ce soit propre

Bonne soirée

A Bientôt

[PinkPanthere]

Quelle réponse rapide ! Merci Igloobel,

- tes 7000 références c'est des références fournisseurs ou produits ?

Alors ce sont 7000 fournisseurs qui doivent chacun recevoir leur fichier.
des produit y'en a plus de 200.000 lignes.

- As-tu pensé a trié tes feuilles
feuille datas : par références fournisseurs puis par références Produits
feuille liste : par références Produits

Oui elles sont exactement triées comme ça pour l'instant


J'ai découpé un extrait du dossier avec juste l'essentiel pou vous donner une idée.

Merci encore ça me soulage de savoir que cette corvée sera bientôt automatique

[Invité]

bonjour,
regarde la pièce jointe!

Code Sub test :

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

1
2
3
4
5
6
7
8
9
10
11
Sub test()
Dim r As Range
Dim fnseur As Foriniseur
Dim L As Long
Set r = Sheets("Liste").Range("a1").CurrentRegion
For L = 2 To r.Rows.Count
   Set fnseur = New Foriniseur
   fnseur.Filtre r(L, 1), ThisWorkbook.Sheets("Datas"), ThisWorkbook.Path
   Set fnseur = Nothing
Next
End Sub

Code Classe Foriniseur :

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
Dim Wb As Workbook
Dim Produit As Worksheet
 
Private Sub Class_Initialize()
Set Wb = Workbooks.Add
Set Produit = Wb.Sheets(1)
End Sub
Public Sub Filtre(Fournisseur As Range, Ws As Worksheet, Path As String)
If Trim("" & Ws.Range("A1")) = "" Then Ws.Range("A1").EntireRow.Delete
Dim F As Workbook
Set F = Workbooks.Add
Produit.Name = Fournisseur
F.Sheets(1).Range("a1") = "Code fournisseur"
F.Sheets(1).Range("a2").NumberFormat = Fournisseur.NumberFormat
F.Sheets(1).Range("a2") = Fournisseur
Dim r As Range
FiltreActif Ws.UsedRange, F.Sheets(1).UsedRange, Produit.Range("a1"), True
F.Close False
 With Produit.Sort
        .SetRange Produit.Range("A1").CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
If Right(Path, 1) <> "\" Then Path = Path & "\"
Produit.Cells.ColumnWidth = 52.29
Produit.Cells.EntireRow.AutoFit
Produit.Cells.EntireColumn.AutoFit
Wb.SaveAs Path & Fournisseur
Wb.Close False
End Sub
 
Private 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

je suis désolé dans mon code je fais le contraire, j'exporte et je trie

[PinkPanthere]

Merci pour ton aide rdurupt ! Ton code marche parfaitement c'est exactement ce que je rêve d'avoir.
J'ai donc un code fonctionnel maintenant mais mon tableau original est un peut différent de celui de test j'ai donc essayé de le modifier;
J'ai rajouté quelques colonnes sans problème, changé les titres des colones "code fournisseur" par 'Code IDM' comme sur l'original par ex, sans problème également mais sur mon fichier original le tableau commence ligne 3 et il y à un titre a reproduire et là je bute :s

[Invité]

Poste un fichier sur ce neveau modèle et je le modifirais.

Je te donnerais les explication également sur le fonctionnement.

Dans le module de classe cherche "code fournisseur"

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
Dim Wb As Workbook
Dim Produit As Worksheet
 
Private Sub Class_Initialize()
Set Wb = Workbooks.Add
Set Produit = Wb.Sheets(1)
End Sub
Public Sub Filtre(Fournisseur As Range, Ws As Worksheet, Path As String)
'If Trim("" & Ws.Range("A1")) = "" Then Ws.Range("A1").EntireRow.Delete
Dim F As Workbook
Set F = Workbooks.Add
Produit.Name = Fournisseur
F.Sheets(1).Range("a1") = "Code fournisseur"
F.Sheets(1).Range("a2").NumberFormat = Fournisseur.NumberFormat
F.Sheets(1).Range("a2") = Fournisseur
Dim r As Range
FiltreActif Ws.Range("A1").CurrentRegion, F.Sheets(1).UsedRange, Produit.Range("a1"), True
F.Close False
 With Produit.Sort
        .SetRange Produit.Range("A1").CurrentRegion
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
If Right(Path, 1) <> "\" Then Path = Path & "\"
Produit.Cells.ColumnWidth = 52.29
Produit.Cells.EntireRow.AutoFit
Produit.Cells.EntireColumn.AutoFit
Wb.SaveAs Path & Fournisseur
Wb.Close False
End Sub
 
Private 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