Filtrer et enregistrer sous en vba

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Vilain
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Vilain

Vilain

XLDnaute Accro
Bonjour,

N'ayant pas fait de vba depuis un moment, je galère à faire quelquechose de très simple...
J'ai une base avec des noms en colonne A et des directions en colonne B.
Je souhaite créer une macro qui va me me créer un fichier pour chaque direction (avec toutes les colonnes de mon fichier (le fichier réel ayant évidemment plus de 2 colonnes)). Le nom du fichier doit être celui de la direction.
Les enregistrements doivent se faire dans un dossier qui existe sur le bureau et nommé A.
Je suis un peu perdu...

Merci d'avance
 

Pièces jointes

Trier par date Trier par votes
Re : Filtrer et enregistrer sous en vba

Salut tototiti,

merci de t'intéresser à mon problème.
Les onglets présents dans mon fichier sont là à titre d'exemplepour ce que je souhaite pbtenir (chaque onglet doit en fait être un fichier avec pour nom le nom de la direction).

Est-ce plus clair ?

A plus
 
Vote positif 0 Vote négatif
Re : Filtrer et enregistrer sous en vba

Bonjour à tous,
Salut Gillus,
Salut Marc 🙂

Un test avec :

VB: 
Option Explicit


Sub Ventile()
Dim CurCell As Range, Titre As Range


Application.ScreenUpdating = 0


Columns("A:J").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlGuess
Range("A1").Select


Set CurCell = ThisWorkbook.Sheets("Data").Range("B1")
Set Titre = ThisWorkbook.Sheets("Data").Range("A1:J1")


While CurCell.Value <> vbNullString
    With GetSheet(CurCell.Value)
        Titre.EntireRow.Copy .Cells(1, 1)
        CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With
    Set CurCell = CurCell.Offset(1, 0)
    Columns("A:J").Columns.AutoFit
Wend


Application.DisplayAlerts = 0
Sheets("Direction").Delete
Application.DisplayAlerts = 1
Sheets("Data").Activate
End Sub


Public Function GetSheet(SheetName As String) As Worksheet
'Cette fonction renvoie la feuille nommée <SheetName> et la crée si elle n'existe pas
Dim CurSheet As Worksheet, Exist As Boolean
Exist = False
For Each CurSheet In ThisWorkbook.Sheets
    If CurSheet.Name = SheetName Then Exist = True
Next CurSheet
If Not Exist Then
    ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SheetName
End If
Set GetSheet = ThisWorkbook.Worksheets(SheetName)
End Function

Prévu pour 10 colonnes et tri sur B puis A.
Ici seulement Création des feuilles

A++
A+ à tous
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Filtrer et enregistrer sous en vba

Salut Jc,

Merci pour ton aide, c'est déjà une belle avancée. Si tu savais comme je me sentais seul face à mon problème depuis hier...
Cela fonctionne bien et en bidouillant un peu, j'ai réussi à l'adapter à mon fichier réel 🙂

Maintenant reste à créer les fichiers et les renommer plutôt que de créer des onglets.

Encore merci

Ps : Les 10 000 approchent à grands pas !!
 
Vote positif 0 Vote négatif
Re : Filtrer et enregistrer sous en vba

Re,

Après quelques heures de galère, je ne parviens toujours pas à faire un sorte que ce soit enregistré dans un classeur portant le nome de la direction...
Une âme charitable pour me venir en aide ?

Merci d'avance.
 
Vote positif 0 Vote négatif
Re : Filtrer et enregistrer sous en vba

Bonjour à tous,

Peux-tu essayer avec :

VB: 
Option Explicit


Sub Ventile()
Dim CurCell As Range, Titre As Range
Dim Rep


Rep = MsgBox("Voulez vous créer les classeurs ?", vbYesNo)


Application.ScreenUpdating = 0


Columns("A:J").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlGuess
Range("A1").Select


Set CurCell = ThisWorkbook.Sheets("Data").Range("B1")
Set Titre = ThisWorkbook.Sheets("Data").Range("A1:J1")


While CurCell.Value <> vbNullString
    With GetSheet(CurCell.Value)
        Titre.EntireRow.Copy .Cells(1, 1)
        CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With
    Set CurCell = CurCell.Offset(1, 0)
    Columns("A:J").Columns.AutoFit
Wend
Application.DisplayAlerts = 0
Sheets("Direction").Delete
Application.DisplayAlerts = 1
Sheets("Data").Activate
If Rep = vbYes Then Call Création
End Sub


Sub Création()
Dim X%
For X = 2 To Sheets.Count
Sheets(X).Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls"
    ActiveWorkbook.Close
    Next
    End Sub




Public Function GetSheet(SheetName As String) As Worksheet
'Cette fonction renvoie la feuille nommée <SheetName> et la crée si elle n'existe pas
Dim CurSheet As Worksheet, Exist As Boolean
Exist = False
For Each CurSheet In ThisWorkbook.Sheets
    If CurSheet.Name = SheetName Then Exist = True
Next CurSheet
If Not Exist Then
    ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SheetName
End If
Set GetSheet = ThisWorkbook.Worksheets(SheetName)
End Function

Les fichiers sont créés dans le même répertoire que ce fichier.

A++
A+ à tous
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Filtrer et enregistrer sous en vba

Bonjour Gillus, Marc, Jean-Claude 🙂

Très à la bourre moi, mais je pense que cette solution est bien complète :

Code: 
Sub CreerFichiers()
Dim F As Worksheet, h&, d As Object, cel As Range, plage As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier existe déjà
On Error Resume Next 'si ce fichier est en plus ouvert...
Set F = ThisWorkbook.Sheets("Base")
F.AutoFilterMode = False 'désactive le filtre automatique
h = F.Cells(F.Rows.Count, "B").End(xlUp).Row
If h = 1 Then Exit Sub
Set d = CreateObject("Scripting.Dictionary")
For Each cel In F.[B2].Resize(h - 1)
  If Not d.exists(cel.Value) And cel <> "" Then
    d(cel.Value) = cel.Value
    F.Copy 'copie la feuille dans un nouveau document
    ActiveSheet.Name = CStr(cel) 'ou un autre nom...
    F.[B1].Resize(h).AutoFilter 1, cel
    Set plage = F.[B1].Resize(h).SpecialCells(xlCellTypeVisible)
    F.AutoFilterMode = False
    plage.EntireRow.Copy ActiveSheet.[A1]
    ActiveSheet.Rows(plage.Count + 1 & ":" & Rows.Count).Delete
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & cel 'chemin à adapter
    If Not ActiveWorkbook.Saved Then MsgBox "Fermez le fichier '" & cel & "' !!!", 48
    ActiveWorkbook.Close False 'facultatif
  End If
Next
F.Parent.Activate
End Sub
Fichier joint.

A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Filtrer et enregistrer sous en vba

Bonjour Jean-Claude 🙂,
Re,

une approche un peu différente 😉

Code: 
Sub SauveDirection()
Dim Dico, ListeDir, ColDir As String, Sh As Worksheet, Dossier As String, i as long
    Dossier = "C:\temp\" ' Dossier de destination des fichiers
    ColDir = "B"
    Set Dico = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    With Sheets("Base")
        For i = 2 To .Range(ColDir & .Rows.Count).End(xlUp).Row
            Dico(.Cells(i, ColDir).Value) = 1
        Next i
        ListeDir = Dico.Keys
        .Range("IV1").Value = .Range(ColDir & "1").Value
        For i = LBound(ListeDir) To UBound(ListeDir)
            .Range("IV2").Value = ListeDir(i)
            Set Sh = ThisWorkbook.Sheets.Add
            .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=.Range("IV1:IV2"), CopyToRange:=Sh.Range("A1"), Unique:=False
            Sh.Name = ListeDir(i)
            Sh.Move
            ActiveWorkbook.SaveAs Filename:=Dossier & ListeDir(i) & ".xls"
            ActiveWorkbook.Close False
        Next i
        .Range("IV1:IV2").ClearContents
    End With
    Application.ScreenUpdating = True
End Sub

Edit : bing, Bonjour job 😉
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Y
  • Résolu(e)
XL 2019 Vérification si dossier existe et création s'il n'existe pas
Réponses
3
Affichages
147
youguybass
Y
V
  • Question Question
XL 2016 ou 2019 - fichier recensant les congés, tickets resto et heures supplémentaires
Réponses
0
Affichages
261
vivi21
V
R
  • Résolu(e)
Microsoft 365 VBA Création dossier + sous dossier + enregistrer le fichier dans le dossier
2
Réponses
17
Affichages
2 K
raf26
R
D
  • Question Question
Microsoft 365 TCD et sélection automatique suivant les filtres
Réponses
2
Affichages
215
Daniel200666
D
H
  • Question Question
XL 2019 masquer des colonne sous condition d'une cellule en vba
Réponses
5
Affichages
259
sylvanu
sylvanu
jlbcall
  • Question Question
Microsoft 365 Macro qui enchaine deshoraires Aller-Retour en fonction de critères
Réponses
10
Affichages
289
bsalv
B
A
  • Question Question
XL 2010 Enregistrer en PDF
Réponses
2
Affichages
427
Appo1985
A
T
  • Résolu(e)
XL 2019 Filtrer certains champs au démarrage avec vba
2
Réponses
15
Affichages
1 K
telemarrk
T
A
  • Question Question
Déplacer données en vba
Réponses
3
Affichages
560
akm
A
L
  • Question Question
XL 2019 Créer des dossiers et sous dossiers avec VBA
2
Réponses
19
Affichages
792
patricktoulon
patricktoulon
T
  • Question Question
XL 2016 Preparer mon publipostage avant export
Réponses
0
Affichages
218
tuti
T
A
  • Question Question
XL 2010 Problème ou alternative à SOMPRODUCT en VBA
Réponses
14
Affichages
845
bruno lemaire
B
A
  • Question Question
Microsoft 365 Tri sur feuille protégée +Aide protection de données déjà saisies
Réponses
2
Affichages
527
TooFatBoy
TooFatBoy
Francoise_nord
  • Question Question
XL 2021 Besoin aide sur macro en VBA
Réponses
0
Affichages
264
Francoise_nord
Francoise_nord
S
  • Résolu(e)
Microsoft 365 vba enregistrer sous en enlevant la lecture seule
Réponses
4
Affichages
686
Scrabblouille
S
J
  • Question Question
Microsoft 365 [RESOLU] vba dupliquer contenu d'une cellule en colonnes jusqu'à ligne vide
Réponses
3
Affichages
230
job75
job75
oguruma
POWERQUERY :: Remplacements multiples dans plusieurs colonnes avec traitements de nettoyage et de conversion de casse
Réponses
0
Affichages
292
oguruma
oguruma
O
  • Question Question
XL 2019 Formulaire vba pour filtrer les données
Réponses
7
Affichages
743
olivier1984
O
J
  • Question Question
Microsoft 365 Copie des onglets dans un fichier séparé depuis une liste en VBA
Réponses
3
Affichages
511
job75
job75
F
  • Question Question
XL 2021 Plages nommées en VBA avec SOMMEPROD
Réponses
7
Affichages
342
vgendron
vgendron
Retour