URGENT : macro visual basic dans excel (suite, suite)
2 réponses
MCA
Daniel,
J'ai généré mes fichiers sans problème. Sauf que pour ma dernière liste
déroulante (qui fait appel à une autre feuille), lorsque je clique dessus, la
liste ne se déroule pas. Il faut obligatoirement que j'ouvre mon gros fichier
initial pour qu'elle s'affiche normalement. Pourquoi ??? Il n'y a que cela
qui me bloque.
Merci de ta réponse
"Daniel" a écrit :
> Bonjour.
> Au temps pour moi. Essaie :
>
> Sub DécouperGRH()
>
> 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 = "D:\Mes documents\"
>
> 'Nom du classeur (racine du nom)
> 'à ceci s'ajoute un numéro dans la procédure
> nom = "ENQUETE"
>
> 'Où sont les données
> 'Nom feuille à déterminer
> Worksheets("Tableau final").Copy Before:=Sheets(1)
>
> Set Sh = ActiveWorkbook.ActiveSheet
> 'Ici tu modifies la lettre N pour
> 'la lettre de la colonne que tu désires.
> With Sh
> Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
> End With
>
> Application.ScreenUpdating = False
> 'Ajout d'un classer
> ThisWorkbook.Sheets("affectation").Copy
> ThisWorkbook.Sheets("Tableau final").Copy Before:=ActiveWorkbook.Sheets(1)
> Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
> Set Wk = ActiveWorkbook
> 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("A9").PasteSpecial xlValues
> Rg1.Offset(1).Clear
> A = A + 1
> 'Sauvegarde du classeur
> Wk.SaveAs Chemin & nom & A & ".xls"
> Wk.Sheets(1).Range("A9:P" &
> Range("A65536").End(xlUp).Row).ClearContents
> .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
>
> Cordialement.
> Daniel
> "MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
> 32682326-447B-48B0-9302-17E476E88746@microsoft.com...
> > Bonjour,
> > J'ai fait ce que Daniel m'avait dit. Seulement, lors de la copie des
> > fichiers, les données (liste déroulante) ne se copient pas. Il n'y a que
> > le
> > 1er fichier généré qui est correct. Les autres sont incomplets, si on
> > clique
> > sur les cellules où il devrait une liste déroulante, il n'y a rien !!
> > Merci de m'éclairer.
> > MCA
> >> Merci beaucoup Daniel, c'est exactement ce que je voulais.
> >> Bon week-end
> >> --
> >> MCA
> >
> >
> >> "Daniel" a écrit :
> >
> >> Mets la macro dans un module du classeur enquete.xls :
> >>
> >> Sub DécouperGRH()
> >>
> >> 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 = "D:\Mes documents\"
> >>
> >> 'Nom du classeur (racine du nom)
> >> 'à ceci s'ajoute un numéro dans la procédure
> >> nom = "ENQUETE"
> >>
> >> 'Où sont les données
> >> 'Nom feuille à déterminer
> >> Worksheets("Tableau final").Copy Before:=Sheets(1)
> >>
> >> Set Sh = ActiveWorkbook.ActiveSheet
> >> 'Ici tu modifies la lettre N pour
> >> 'la lettre de la colonne que tu désires.
> >> With Sh
> >> Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
> >> End With
> >>
> >> Application.ScreenUpdating = False
> >> 'Ajout d'un classer
> >> ThisWorkbook.Sheets("affectation").Copy
> >> ThisWorkbook.Sheets("Tableau final").Copy
> >> Before:=ActiveWorkbook.Sheets(1)
> >> Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
> >> Set Wk = ActiveWorkbook
> >> 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("A9")
> >> Rg1.Offset(1).Clear
> >> A = A + 1
> >> 'Sauvegarde du classeur
> >> Wk.SaveAs Chemin & nom & A & ".xls"
> >> Wk.Sheets(1).Range("A9:P" &
> >> Range("A65536").End(xlUp).Row).ClearContents
> >> .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
> >>
> >> Cordialement.
> >> Daniel
> >> "MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
> >> A8F29840-1617-4CC3-9692-1587C3973F41@microsoft.com...
> >> > Merci Daniel de ta réponse.
> >> > Ci-dessous le lien pour accéder au fichier :
> >> > http://cjoint.com/?djojJg2G3q
> >> >
> >> > Précisions :
> >> > -Dans chaque fichier, je veux copier le titre qui va de la ligne 1 à 8
> >> > -j'ai des listes déroulantes dans les colonnes F, L, O (pour cette
> >> > dernière
> >> > colonne, le détail de ma liste déroulante se trouve dans la feuille
> >> > appelée
> >> > "affectation" que je masque par la suite.
> >> > -les feuilles à récupérer dans chaque fichier sont "tableau final" et
> >> > "affectation".
> >> >
> >> > Je ne sais pas si mes explications sont suffisamment claires pour
> >> > t'apporter
> >> > les éclaircissements attendus.
> >> >
> >> >
> >> > --
> >> > MCA
> >> >
> >> >
> >> > "Daniel" a écrit :
> >> >
> >> >> > - j'ai des colonnes avec des listes déroulantes (données/validation)
> >> >> > - et j'ai deux feuilles.
> >> >>
> >> >> Bonjour.
> >> >> Quelques précisions.
> >> >> Les classeurs cibles doivent récupérer les listes de validation, et,
> >> >> dans
> >> >> ce
> >> >> cas, comment sont-elles définies et à quelles plages
> >> >> s'appliquent-elles ?
> >> >> Tu veux également récupérer deux feuilles dans les classeurs cible ?,
> >> >> les
> >> >> données des deux feuilles ont-elles la même structure ?
> >> >> Si possible, dépose un classeur exemple (en effaçant les données
> >> >> confidentielles) et en diminuant la masse de données afin que le
> >> >> classeur
> >> >> ne
> >> >> soit pas trop gros sur le site :
> >> >> www.cjoint.com et poste l'adresse générée.
> >> >> Cordialement.
> >> >> Daniel
> >
> >
> > --
> > MCA
>
>
>
--
MCA
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Daniel
Je n'ai vérifié que sur le premier fichier :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Sheets("affectation").Range("A1:A42").Name = "affectation" Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Daniel "MCA" a écrit dans le message de news:
Daniel, J'ai généré mes fichiers sans problème. Sauf que pour ma dernière liste déroulante (qui fait appel à une autre feuille), lorsque je clique dessus, la liste ne se déroule pas. Il faut obligatoirement que j'ouvre mon gros fichier initial pour qu'elle s'affiche normalement. Pourquoi ??? Il n'y a que cela qui me bloque. Merci de ta réponse
Bonjour. Au temps pour moi. Essaie :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Bonjour, J'ai fait ce que Daniel m'avait dit. Seulement, lors de la copie des fichiers, les données (liste déroulante) ne se copient pas. Il n'y a que le 1er fichier généré qui est correct. Les autres sont incomplets, si on clique sur les cellules où il devrait une liste déroulante, il n'y a rien !! Merci de m'éclairer. MCA
Merci beaucoup Daniel, c'est exactement ce que je voulais. Bon week-end -- MCA
Mets la macro dans un module du classeur enquete.xls :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9") Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Merci Daniel de ta réponse. Ci-dessous le lien pour accéder au fichier : http://cjoint.com/?djojJg2G3q
Précisions : -Dans chaque fichier, je veux copier le titre qui va de la ligne 1 à 8 -j'ai des listes déroulantes dans les colonnes F, L, O (pour cette dernière colonne, le détail de ma liste déroulante se trouve dans la feuille appelée "affectation" que je masque par la suite. -les feuilles à récupérer dans chaque fichier sont "tableau final" et "affectation".
Je ne sais pas si mes explications sont suffisamment claires pour t'apporter les éclaircissements attendus.
-- MCA
- j'ai des colonnes avec des listes déroulantes (données/validation) - et j'ai deux feuilles.
Bonjour. Quelques précisions. Les classeurs cibles doivent récupérer les listes de validation, et, dans ce cas, comment sont-elles définies et à quelles plages s'appliquent-elles ? Tu veux également récupérer deux feuilles dans les classeurs cible ?, les données des deux feuilles ont-elles la même structure ? Si possible, dépose un classeur exemple (en effaçant les données confidentielles) et en diminuant la masse de données afin que le classeur ne soit pas trop gros sur le site : www.cjoint.com et poste l'adresse générée. Cordialement. Daniel
-- MCA
--
MCA
Je n'ai vérifié que sur le premier fichier :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "ENQUETE"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
ThisWorkbook.Sheets("affectation").Copy
ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1)
Sheets("affectation").Range("A1:A42").Name = "affectation"
Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
Set Wk = ActiveWorkbook
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("A9").PasteSpecial xlValues
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Range("A9:P" &
Range("A65536").End(xlUp).Row).ClearContents
.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
Daniel
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
4E399442-2BAD-4EAE-A82C-CE86EBAB97F4@microsoft.com...
Daniel,
J'ai généré mes fichiers sans problème. Sauf que pour ma dernière liste
déroulante (qui fait appel à une autre feuille), lorsque je clique dessus,
la
liste ne se déroule pas. Il faut obligatoirement que j'ouvre mon gros
fichier
initial pour qu'elle s'affiche normalement. Pourquoi ??? Il n'y a que cela
qui me bloque.
Merci de ta réponse
Bonjour.
Au temps pour moi. Essaie :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "ENQUETE"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
ThisWorkbook.Sheets("affectation").Copy
ThisWorkbook.Sheets("Tableau final").Copy
Before:¬tiveWorkbook.Sheets(1)
Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
Set Wk = ActiveWorkbook
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("A9").PasteSpecial xlValues
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Range("A9:P" &
Range("A65536").End(xlUp).Row).ClearContents
.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
Cordialement.
Daniel
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
32682326-447B-48B0-9302-17E476E88746@microsoft.com...
Bonjour,
J'ai fait ce que Daniel m'avait dit. Seulement, lors de la copie des
fichiers, les données (liste déroulante) ne se copient pas. Il n'y a
que
le
1er fichier généré qui est correct. Les autres sont incomplets, si on
clique
sur les cellules où il devrait une liste déroulante, il n'y a rien !!
Merci de m'éclairer.
MCA
Merci beaucoup Daniel, c'est exactement ce que je voulais.
Bon week-end
--
MCA
Mets la macro dans un module du classeur enquete.xls :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "ENQUETE"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
ThisWorkbook.Sheets("affectation").Copy
ThisWorkbook.Sheets("Tableau final").Copy
Before:¬tiveWorkbook.Sheets(1)
Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
Set Wk = ActiveWorkbook
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("A9")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Range("A9:P" &
Range("A65536").End(xlUp).Row).ClearContents
.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
Cordialement.
Daniel
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
A8F29840-1617-4CC3-9692-1587C3973F41@microsoft.com...
Merci Daniel de ta réponse.
Ci-dessous le lien pour accéder au fichier :
http://cjoint.com/?djojJg2G3q
Précisions :
-Dans chaque fichier, je veux copier le titre qui va de la ligne 1 à
8
-j'ai des listes déroulantes dans les colonnes F, L, O (pour cette
dernière
colonne, le détail de ma liste déroulante se trouve dans la feuille
appelée
"affectation" que je masque par la suite.
-les feuilles à récupérer dans chaque fichier sont "tableau final"
et
"affectation".
Je ne sais pas si mes explications sont suffisamment claires pour
t'apporter
les éclaircissements attendus.
--
MCA
- j'ai des colonnes avec des listes déroulantes
(données/validation)
- et j'ai deux feuilles.
Bonjour.
Quelques précisions.
Les classeurs cibles doivent récupérer les listes de validation,
et,
dans
ce
cas, comment sont-elles définies et à quelles plages
s'appliquent-elles ?
Tu veux également récupérer deux feuilles dans les classeurs cible
?,
les
données des deux feuilles ont-elles la même structure ?
Si possible, dépose un classeur exemple (en effaçant les données
confidentielles) et en diminuant la masse de données afin que le
classeur
ne
soit pas trop gros sur le site :
www.cjoint.com et poste l'adresse générée.
Cordialement.
Daniel
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Sheets("affectation").Range("A1:A42").Name = "affectation" Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Daniel "MCA" a écrit dans le message de news:
Daniel, J'ai généré mes fichiers sans problème. Sauf que pour ma dernière liste déroulante (qui fait appel à une autre feuille), lorsque je clique dessus, la liste ne se déroule pas. Il faut obligatoirement que j'ouvre mon gros fichier initial pour qu'elle s'affiche normalement. Pourquoi ??? Il n'y a que cela qui me bloque. Merci de ta réponse
Bonjour. Au temps pour moi. Essaie :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Bonjour, J'ai fait ce que Daniel m'avait dit. Seulement, lors de la copie des fichiers, les données (liste déroulante) ne se copient pas. Il n'y a que le 1er fichier généré qui est correct. Les autres sont incomplets, si on clique sur les cellules où il devrait une liste déroulante, il n'y a rien !! Merci de m'éclairer. MCA
Merci beaucoup Daniel, c'est exactement ce que je voulais. Bon week-end -- MCA
Mets la macro dans un module du classeur enquete.xls :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9") Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Merci Daniel de ta réponse. Ci-dessous le lien pour accéder au fichier : http://cjoint.com/?djojJg2G3q
Précisions : -Dans chaque fichier, je veux copier le titre qui va de la ligne 1 à 8 -j'ai des listes déroulantes dans les colonnes F, L, O (pour cette dernière colonne, le détail de ma liste déroulante se trouve dans la feuille appelée "affectation" que je masque par la suite. -les feuilles à récupérer dans chaque fichier sont "tableau final" et "affectation".
Je ne sais pas si mes explications sont suffisamment claires pour t'apporter les éclaircissements attendus.
-- MCA
- j'ai des colonnes avec des listes déroulantes (données/validation) - et j'ai deux feuilles.
Bonjour. Quelques précisions. Les classeurs cibles doivent récupérer les listes de validation, et, dans ce cas, comment sont-elles définies et à quelles plages s'appliquent-elles ? Tu veux également récupérer deux feuilles dans les classeurs cible ?, les données des deux feuilles ont-elles la même structure ? Si possible, dépose un classeur exemple (en effaçant les données confidentielles) et en diminuant la masse de données afin que le classeur ne soit pas trop gros sur le site : www.cjoint.com et poste l'adresse générée. Cordialement. Daniel
-- MCA
--
MCA
MCA
Merci beaucoup Daniel. C'est parfait !! Il va vraiment falloir que je m'y mette car c'est fou ce que l'on peut faire ... Merci encore -- MCA
Je n'ai vérifié que sur le premier fichier :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Sheets("affectation").Range("A1:A42").Name = "affectation" Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Daniel "MCA" a écrit dans le message de news:
Daniel, J'ai généré mes fichiers sans problème. Sauf que pour ma dernière liste déroulante (qui fait appel à une autre feuille), lorsque je clique dessus, la liste ne se déroule pas. Il faut obligatoirement que j'ouvre mon gros fichier initial pour qu'elle s'affiche normalement. Pourquoi ??? Il n'y a que cela qui me bloque. Merci de ta réponse
Bonjour. Au temps pour moi. Essaie :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Bonjour, J'ai fait ce que Daniel m'avait dit. Seulement, lors de la copie des fichiers, les données (liste déroulante) ne se copient pas. Il n'y a que le 1er fichier généré qui est correct. Les autres sont incomplets, si on clique sur les cellules où il devrait une liste déroulante, il n'y a rien !! Merci de m'éclairer. MCA
Merci beaucoup Daniel, c'est exactement ce que je voulais. Bon week-end -- MCA
Mets la macro dans un module du classeur enquete.xls :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9") Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Merci Daniel de ta réponse. Ci-dessous le lien pour accéder au fichier : http://cjoint.com/?djojJg2G3q
Précisions : -Dans chaque fichier, je veux copier le titre qui va de la ligne 1 à 8 -j'ai des listes déroulantes dans les colonnes F, L, O (pour cette dernière colonne, le détail de ma liste déroulante se trouve dans la feuille appelée "affectation" que je masque par la suite. -les feuilles à récupérer dans chaque fichier sont "tableau final" et "affectation".
Je ne sais pas si mes explications sont suffisamment claires pour t'apporter les éclaircissements attendus.
-- MCA
- j'ai des colonnes avec des listes déroulantes (données/validation) - et j'ai deux feuilles.
Bonjour. Quelques précisions. Les classeurs cibles doivent récupérer les listes de validation, et, dans ce cas, comment sont-elles définies et à quelles plages s'appliquent-elles ? Tu veux également récupérer deux feuilles dans les classeurs cible ?, les données des deux feuilles ont-elles la même structure ? Si possible, dépose un classeur exemple (en effaçant les données confidentielles) et en diminuant la masse de données afin que le classeur ne soit pas trop gros sur le site : www.cjoint.com et poste l'adresse générée. Cordialement. Daniel
-- MCA
--
MCA
Merci beaucoup Daniel. C'est parfait !!
Il va vraiment falloir que je m'y mette car c'est fou ce que l'on peut faire
...
Merci encore
--
MCA
Je n'ai vérifié que sur le premier fichier :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "ENQUETE"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
ThisWorkbook.Sheets("affectation").Copy
ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1)
Sheets("affectation").Range("A1:A42").Name = "affectation"
Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
Set Wk = ActiveWorkbook
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("A9").PasteSpecial xlValues
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Range("A9:P" &
Range("A65536").End(xlUp).Row).ClearContents
.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
Daniel
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
4E399442-2BAD-4EAE-A82C-CE86EBAB97F4@microsoft.com...
Daniel,
J'ai généré mes fichiers sans problème. Sauf que pour ma dernière liste
déroulante (qui fait appel à une autre feuille), lorsque je clique dessus,
la
liste ne se déroule pas. Il faut obligatoirement que j'ouvre mon gros
fichier
initial pour qu'elle s'affiche normalement. Pourquoi ??? Il n'y a que cela
qui me bloque.
Merci de ta réponse
Bonjour.
Au temps pour moi. Essaie :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "ENQUETE"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
ThisWorkbook.Sheets("affectation").Copy
ThisWorkbook.Sheets("Tableau final").Copy
Before:¬tiveWorkbook.Sheets(1)
Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
Set Wk = ActiveWorkbook
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("A9").PasteSpecial xlValues
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Range("A9:P" &
Range("A65536").End(xlUp).Row).ClearContents
.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
Cordialement.
Daniel
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
32682326-447B-48B0-9302-17E476E88746@microsoft.com...
Bonjour,
J'ai fait ce que Daniel m'avait dit. Seulement, lors de la copie des
fichiers, les données (liste déroulante) ne se copient pas. Il n'y a
que
le
1er fichier généré qui est correct. Les autres sont incomplets, si on
clique
sur les cellules où il devrait une liste déroulante, il n'y a rien !!
Merci de m'éclairer.
MCA
Merci beaucoup Daniel, c'est exactement ce que je voulais.
Bon week-end
--
MCA
Mets la macro dans un module du classeur enquete.xls :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom)
'à ceci s'ajoute un numéro dans la procédure
nom = "ENQUETE"
'Où sont les données
'Nom feuille à déterminer
Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet
'Ici tu modifies la lettre N pour
'la lettre de la colonne que tu désires.
With Sh
Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row)
End With
Application.ScreenUpdating = False
'Ajout d'un classer
ThisWorkbook.Sheets("affectation").Copy
ThisWorkbook.Sheets("Tableau final").Copy
Before:¬tiveWorkbook.Sheets(1)
Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents
Set Wk = ActiveWorkbook
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("A9")
Rg1.Offset(1).Clear
A = A + 1
'Sauvegarde du classeur
Wk.SaveAs Chemin & nom & A & ".xls"
Wk.Sheets(1).Range("A9:P" &
Range("A65536").End(xlUp).Row).ClearContents
.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
Cordialement.
Daniel
"MCA" <MCA@discussions.microsoft.com> a écrit dans le message de news:
A8F29840-1617-4CC3-9692-1587C3973F41@microsoft.com...
Merci Daniel de ta réponse.
Ci-dessous le lien pour accéder au fichier :
http://cjoint.com/?djojJg2G3q
Précisions :
-Dans chaque fichier, je veux copier le titre qui va de la ligne 1 à
8
-j'ai des listes déroulantes dans les colonnes F, L, O (pour cette
dernière
colonne, le détail de ma liste déroulante se trouve dans la feuille
appelée
"affectation" que je masque par la suite.
-les feuilles à récupérer dans chaque fichier sont "tableau final"
et
"affectation".
Je ne sais pas si mes explications sont suffisamment claires pour
t'apporter
les éclaircissements attendus.
--
MCA
- j'ai des colonnes avec des listes déroulantes
(données/validation)
- et j'ai deux feuilles.
Bonjour.
Quelques précisions.
Les classeurs cibles doivent récupérer les listes de validation,
et,
dans
ce
cas, comment sont-elles définies et à quelles plages
s'appliquent-elles ?
Tu veux également récupérer deux feuilles dans les classeurs cible
?,
les
données des deux feuilles ont-elles la même structure ?
Si possible, dépose un classeur exemple (en effaçant les données
confidentielles) et en diminuant la masse de données afin que le
classeur
ne
soit pas trop gros sur le site :
www.cjoint.com et poste l'adresse générée.
Cordialement.
Daniel
Merci beaucoup Daniel. C'est parfait !! Il va vraiment falloir que je m'y mette car c'est fou ce que l'on peut faire ... Merci encore -- MCA
Je n'ai vérifié que sur le premier fichier :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Sheets("affectation").Range("A1:A42").Name = "affectation" Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Daniel "MCA" a écrit dans le message de news:
Daniel, J'ai généré mes fichiers sans problème. Sauf que pour ma dernière liste déroulante (qui fait appel à une autre feuille), lorsque je clique dessus, la liste ne se déroule pas. Il faut obligatoirement que j'ouvre mon gros fichier initial pour qu'elle s'affiche normalement. Pourquoi ??? Il n'y a que cela qui me bloque. Merci de ta réponse
Bonjour. Au temps pour moi. Essaie :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9").PasteSpecial xlValues Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Bonjour, J'ai fait ce que Daniel m'avait dit. Seulement, lors de la copie des fichiers, les données (liste déroulante) ne se copient pas. Il n'y a que le 1er fichier généré qui est correct. Les autres sont incomplets, si on clique sur les cellules où il devrait une liste déroulante, il n'y a rien !! Merci de m'éclairer. MCA
Merci beaucoup Daniel, c'est exactement ce que je voulais. Bon week-end -- MCA
Mets la macro dans un module du classeur enquete.xls :
Sub DécouperGRH()
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 = "D:Mes documents"
'Nom du classeur (racine du nom) 'à ceci s'ajoute un numéro dans la procédure nom = "ENQUETE"
'Où sont les données 'Nom feuille à déterminer Worksheets("Tableau final").Copy Before:=Sheets(1)
Set Sh = ActiveWorkbook.ActiveSheet 'Ici tu modifies la lettre N pour 'la lettre de la colonne que tu désires. With Sh Set Rg = .Range("A9:P" & .Range("A65536").End(xlUp).Row) End With
Application.ScreenUpdating = False 'Ajout d'un classer ThisWorkbook.Sheets("affectation").Copy ThisWorkbook.Sheets("Tableau final").Copy Before:¬tiveWorkbook.Sheets(1) Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents Set Wk = ActiveWorkbook 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("A9") Rg1.Offset(1).Clear A = A + 1 'Sauvegarde du classeur Wk.SaveAs Chemin & nom & A & ".xls" Wk.Sheets(1).Range("A9:P" & Range("A65536").End(xlUp).Row).ClearContents .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
Cordialement. Daniel "MCA" a écrit dans le message de news:
Merci Daniel de ta réponse. Ci-dessous le lien pour accéder au fichier : http://cjoint.com/?djojJg2G3q
Précisions : -Dans chaque fichier, je veux copier le titre qui va de la ligne 1 à 8 -j'ai des listes déroulantes dans les colonnes F, L, O (pour cette dernière colonne, le détail de ma liste déroulante se trouve dans la feuille appelée "affectation" que je masque par la suite. -les feuilles à récupérer dans chaque fichier sont "tableau final" et "affectation".
Je ne sais pas si mes explications sont suffisamment claires pour t'apporter les éclaircissements attendus.
-- MCA
- j'ai des colonnes avec des listes déroulantes (données/validation) - et j'ai deux feuilles.
Bonjour. Quelques précisions. Les classeurs cibles doivent récupérer les listes de validation, et, dans ce cas, comment sont-elles définies et à quelles plages s'appliquent-elles ? Tu veux également récupérer deux feuilles dans les classeurs cible ?, les données des deux feuilles ont-elles la même structure ? Si possible, dépose un classeur exemple (en effaçant les données confidentielles) et en diminuant la masse de données afin que le classeur ne soit pas trop gros sur le site : www.cjoint.com et poste l'adresse générée. Cordialement. Daniel