Decouper un fichier en plusieurs plus petits

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/th...

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.


Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.


http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/thread/4864bb23fc3f32da?scoring=d&qÞcouper+un+tableau&hl=fr

merci d'avance

Akim


--------------------------------------
Sub Découper()


Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String


'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"


'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"


'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)


Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With


Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)


Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------

Bonjour,

Possibilité manuelle.
Etablis la liste de tous les responsables.
Dupliques ton classeur en autant que de responsables
Dans chacun tu mets la liste où en face du nom du responsable de
chaque classeur tu mets 1 et tous les autres 2.
En groupe de travail tu insère dans chaque feuille une colonne qui lit
le nom du responsable et ajoute le numéro correspondant selon la
liste.
Tu trie chaque feuille, tu gardes tout ce qui est 1 et supprime tout
ce qui est 2.

Cordialement.

lSteph

On 25 juil, 15:16, max-75 <google.20.max...@spamgourmet.com> wrote:

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/th...

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/th...

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------

hello à tous,

Je ne connais pas la structure de ton classeur donc je propose une
solution peut-être irréaliste.

Il me semble que tu pourrais créer un tableau croisé qui regroupe les
données des diverses feuilles.
Ce tableau prendrais les responsable en page.
Ensuite lancer "afficher les pages" qui créerait les divers tableaux que
tu as besoin.

HTH

Paul V

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/th...

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -

Bonjour,

Sub CreeClasseurs()
Application.DisplayAlerts = False
Sheets("consolide").[A1].CurrentRegion.Offset(1, 0).Clear
For Each s In Array("BD1", "BD2", "BD3")
Range(Sheets(s).[A2], Sheets(s).
[A65000].End(xlUp).End(xlToRight)).Copy _
[A65000].End(xlUp).Offset(1, 0)
Next s
'--
[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[g1],
Unique:=True
For Each c In Range("G2", Range("G65000").End(xlUp))
Range("G2") = c
Sheets("Modèle").Select
Sheets("Consolide").[A1:D10000].AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("consolide").[G1:G2], _
CopyToRange:=Sheets("Modèle").[A1:C1], Unique:=False
ActiveSheet.Copy
ActiveSheet.Name = c
ActiveWorkbook.SaveAs Filename:=c
ActiveWorkbook.Close
Sheets("consolide").Select
Next c
End Sub

http://boisgontierjacques.free.fr/fichiers/Onglets/CreeClasseursRespo...

JB

On 25 juil, 15:16, max-75 <google.20.max...@spamgourmet.com> wrote:

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/th...

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -

C'est pour eviter ce cote fastidieux que je souhaitais une macro du
genre de celle cite en exemple..
Aujourdh'ui, je dois creer un filtre auto, filtrer la premiere feuille
selon le premier responsable de la liste, copier les donnees relative
à ce classeur, en creer un nouveau à son nom, le reformater (nom des
onglets) coller les infos, partir sur la seconde feuille du classeur
source filtrer avec le meme nom, reformater le second onglet et
coller, repeter cette operation autant de fois par onglet puis ensuite
autant de fois que de responsables. Une fois que tous les noms de la
premiere feuille ont ete filtrees, recommencer avec ceux de la seconde
feuille en recherchant ceux qui n'ont pas ete traite par le premier
passage....trop fastidieux. Tu ajoutes à celà les interruption
intempestives des collegues et tu multiplies le risque d'erreurs ...

On 25 juil, 17:18, JB <boisgont...@hotmail.com> wrote:

Bonjour,

Sub CreeClasseurs()
Application.DisplayAlerts = False
Sheets("consolide").[A1].CurrentRegion.Offset(1, 0).Clear
For Each s In Array("BD1", "BD2", "BD3")
Range(Sheets(s).[A2], Sheets(s).
[A65000].End(xlUp).End(xlToRight)).Copy _
[A65000].End(xlUp).Offset(1, 0)
Next s
'--
[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[g1 ],
Unique:=True
For Each c In Range("G2", Range("G65000").End(xlUp))
Range("G2") = c
Sheets("Modèle").Select
Sheets("Consolide").[A1:D10000].AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("consolide").[G1:G2], _
CopyToRange:=Sheets("Modèle").[A1:C1], Unique:=False
ActiveSheet.Copy
ActiveSheet.Name = c
ActiveWorkbook.SaveAs Filename:=c
ActiveWorkbook.Close
Sheets("consolide").Select
Next c
End Sub

http://boisgontierjacques.free.fr/fichiers/Onglets/CreeClasseursRespo...

JB

On 25 juil, 15:16, max-75 <google.20.max...@spamgourmet.com> wrote:

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/th. ..

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------- Masquer le texte des message s précédents -

- Afficher le texte des messages précédents -

Super JB,

Ce classeur va m'etre tres utile pour une autre activite.
Ici cependant, l'information d'origine est volontairement repartie
dans differents onglets car elle repond à differentes requete.
Je vais preciser et simplifier un peu le context.
jai un classeur qui regroupe dans chaque onglet un type d'erreur de
saisie ou de donnee manquante.
ex:
onglet1: extraction avec entete des commandes où il manque le nom du
commercial...
onglet2: extraction avec entete des commandes où il manque le num de
tel...
Chaque onglet comporte entre autres une colonne avec le nom de la
personne à contacter pour corriger la saisie.
L'idee est de fournir un fichier excell à chaque personne qui reprends
chaque onglet telquel mais filtre avec les info qui la concerne.
Ainsi, TATA recoit un fichier excell comportant en onglet1 toutes ses
commandes ou elle doit ajouter le nom du commercial, en onglet2 celle
ou il manque un num de tel...- Masquer le texte des messages précéden ts -

- Afficher le texte des messages précédents -

On 25 juil, 17:18, JB <boisgont...@hotmail.com> wrote:

Bonjour,

Sub CreeClasseurs()
Application.DisplayAlerts = False
Sheets("consolide").[A1].CurrentRegion.Offset(1, 0).Clear
For Each s In Array("BD1", "BD2", "BD3")
Range(Sheets(s).[A2], Sheets(s).
[A65000].End(xlUp).End(xlToRight)).Copy _
[A65000].End(xlUp).Offset(1, 0)
Next s
'--
[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[g1 ],
Unique:=True
For Each c In Range("G2", Range("G65000").End(xlUp))
Range("G2") = c
Sheets("Modèle").Select
Sheets("Consolide").[A1:D10000].AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("consolide").[G1:G2], _
CopyToRange:=Sheets("Modèle").[A1:C1], Unique:=False
ActiveSheet.Copy
ActiveSheet.Name = c
ActiveWorkbook.SaveAs Filename:=c
ActiveWorkbook.Close
Sheets("consolide").Select
Next c
End Sub

http://boisgontierjacques.free.fr/fichiers/Onglets/CreeClasseursRespo...

JB

On 25 juil, 15:16, max-75 <google.20.max...@spamgourmet.com> wrote:

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiterai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feuille
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/th. ..

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------- Masquer le texte des message s précédents -

- Afficher le texte des messages précédents -

Super JB,

Ce classeur va m'etre tres utile pour une autre activite.
Ici cependant, l'information d'origine est volontairement repartie
dans differents onglets car elle repond à differentes requete.
Je vais preciser et simplifier un peu le context.
jai un classeur qui regroupe dans chaque onglet un type d'erreur de
saisie ou de donnee manquante.
ex:
onglet1: extraction avec entete des commandes où il manque le nom du
commercial...
onglet2: extraction avec entete des commandes où il manque le num de
tel...
Chaque onglet comporte entre autres une colonne avec le nom de la
personne à contacter pour corriger la saisie.
L'idee est de fournir un fichier excell à chaque personne qui reprends
chaque onglet telquel mais filtre avec les info qui la concerne.
Ainsi, TATA recoit un fichier excell comportant en onglet1 toutes ses
commandes ou elle doit ajouter le nom du commercial, en onglet2 celle
ou il manque un num de tel...- Masquer le texte des messages précéden ts -

- Afficher le texte des messages précédents -

http://boisgontierjacques.free.fr/fichiers/Onglets/CreeClasseursRespo...

JB

On 25 juil, 18:27, max-75 <google.20.max...@spamgourmet.com> wrote:

On 25 juil, 17:18, JB <boisgont...@hotmail.com> wrote:

Bonjour,

Sub CreeClasseurs()
Application.DisplayAlerts = False
Sheets("consolide").[A1].CurrentRegion.Offset(1, 0).Clear
For Each s In Array("BD1", "BD2", "BD3")
Range(Sheets(s).[A2], Sheets(s).
[A65000].End(xlUp).End(xlToRight)).Copy _
[A65000].End(xlUp).Offset(1, 0)
Next s
'--
[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[ g1],
Unique:=True
For Each c In Range("G2", Range("G65000").End(xlUp))
Range("G2") = c
Sheets("Modèle").Select
Sheets("Consolide").[A1:D10000].AdvancedFilter
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("consolide").[G1:G2], _
CopyToRange:=Sheets("Modèle").[A1:C1], Unique:=False
ActiveSheet.Copy
ActiveSheet.Name = c
ActiveWorkbook.SaveAs Filename:=c
ActiveWorkbook.Close
Sheets("consolide").Select
Next c
End Sub

http://boisgontierjacques.free.fr/fichiers/Onglets/CreeClasseursRespo. ..

JB

On 25 juil, 15:16, max-75 <google.20.max...@spamgourmet.com> wrote:

Bonjour à tous,

J'ai regulierement un classeur qui contient plusieurs feuilles.
J'ai une colonne 'responsable' dans chaque feuilles et je souhaiter ai
creer un classeur par responsable afin de leur envoyer.
Chaque classeur ainsi genere serait une image de mon classeur
d'origine mais ne comportant que les donnees relatives à chaque
responsables.
contrainte: il faudra scanner la colonne responsable de chaque feui lle
pour en avoir la liste exhaustive.

Ce script de michdenis, publie le 24nov 2005 correspond exactement à
ma demande sauf qu'il ne s'applique qu'à une feuille alors que je
souhaiterais que le filtre s'applique à tous mes onglets.

http://groups.google.fr/group/microsoft.public.fr.excel/browse_frm/t h...

merci d'avance

Akim

--------------------------------------
Sub Découper()

Dim Rg As Range, A As Integer
Dim Wk As Workbook, Rg1 As Range
Dim Sh As Worksheet, Chemin As String

'Chemin où tu veux enregistrer chacun des fichiers
Chemin = "C:"

'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "Denis"

'Où sont les données
'Nom feuille à déterminer
Worksheets("Feuil1").Copy before:=Sheets(1)

Set Sh = ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A1:N" & .Range("A65536").End(xlUp).Row)
End With

Application.ScreenUpdating = False
'Ajout d'un classer
Set Wk = Workbooks.Add(-4167)

Application.EnableEvents = False
Do
With Rg
'trier par ordre croissant
.Sort Key1:=Rg(2, 1), Header:=xlYes
'Filtre automatique
.AutoFilter Field:=1, Criteria1:=Rg(2, 1)
Set Rg1 = Sh.Range("_FilterDataBase")
.SpecialCells (xlCellTypeVisible)
'Copie du résultat du filtre vers nouveau classeur
Rg1.Copy Wk.Sheets(1).Range("A1")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Cells.Clear
.AutoFilter
.Sort Key1:=Rg(2, 1), Header:=xlYes
End With
Loop Until Rg(2, 1) = ""
Application.EnableEvents = True
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set Rg1 = Nothing
End Sub
'--------------------------------------- Masquer le texte des messa ges précédents -

- Afficher le texte des messages précédents -

Super JB,

Ce classeur va m'etre tres utile pour une autre activite.
Ici cependant, l'information d'origine est volontairement repartie
dans differents onglets car elle repond à differentes requete.
Je vais preciser et simplifier un peu le context.
jai un classeur qui regroupe dans chaque onglet un type d'erreur de
saisie ou de donnee manquante.
ex:
onglet1: extraction avec entete des commandes où il manque le nom du
commercial...
onglet2: extraction avec entete des commandes où il manque le num de
tel...
Chaque onglet comporte entre autres une colonne avec le nom de la
personne à contacter pour corriger la saisie.
L'idee est de fournir un fichier excell à chaque personne qui reprends
chaque onglet telquel mais filtre avec les info qui la concerne.
Ainsi, TATA recoit un fichier excell comportant en onglet1 toutes ses
commandes ou elle doit ajouter le nom du commercial, en onglet2 celle
ou il manque un num de tel...- Masquer le texte des messages précéd ents -

- Afficher le texte des messages précédents -- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -