Decouper un fichier en plusieurs plus petits
Le
max-75
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/micro.../thread/4=
864bb23fc3f32da?scoring=d&q=decouper+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
'--
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/micro.../thread/4=
864bb23fc3f32da?scoring=d&q=decouper+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
'--
Poser une question
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
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 Isteph,
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 ...
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:úlse
ActiveSheet.Copy
ActiveSheet.Name = c
ActiveWorkbook.SaveAs Filename:=c
ActiveWorkbook.Close
Sheets("consolide").Select
Next c
End Sub
http://boisgontierjacques.free.fr/f...esponsable .xls
JB
On 25 juil, 15:16, max-75
ca pourrait marcher....
pour preciser un peu, je travaille avec des extractions de base oracle
(-> liste avec entetes). L'idee est que ces extractions traquent les
anomalies (donnee manquante, incoherente....).
Chaque requete SQL retourne son resultat dans une feuille. J'actualise
les requetes est l'idee et d'envoyer un classeur à chaque personne
responsable de la saisie pour qu'elle corrige ses erreurs...
je souhaiterai eviter de decouper mon fichier d'origine pour n'avoir
qu'une feuille et utiliser la macro cite car j'ai l'intention de
developper beaucoup de queries et je prefere pour de questions
d'organiseation garder 1 classeur par type de requetes...
Voili voila.
Si quelqu'un pouvais m'aider à adapter la macro ou m'indiquer une
script equivalent...
merci
Akim