Séparer des onglets en feuille excel

F

FCAFE

XLDnaute Nouveau
Bonjour


Est il possible de séparer des onglets excel en feuille séparer par un petit programme s'il vous plait
par exemple mettre les onglets sur le bureau en attendant de les traiter, sachant que mais onglet a dispatcher
commence toujours par fr ou qs

Je vous remercie de votre aide

Version excel 2003 - 2010 l'année prochaine
 

Pièces jointes

  • fanchon 3.xls
    15.5 KB · Affichages: 114
  • fanchon 3.xls
    15.5 KB · Affichages: 141
  • fanchon 3.xls
    15.5 KB · Affichages: 158
Trier par date Trier par votes
Dormeur74

Dormeur74

XLDnaute Occasionnel
Re : Séparer des onglets en feuille excel

Essaye cette macro.

Code: 
Sub Macro1()
    Dim cheminBureau, fichier As String
    Dim objShell, objFolder, objFolderItem As Object
    Dim x, nbFeuilles As Integer
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(&H10)
    Set objFolderItem = objFolder.Self
    cheminBureau = objFolderItem.Path
    nbFeuilles = Sheets.Count
    
    For x = 1 To nbFeuilles
        Sheets(x).Activate
        fichier = Sheets(x).Name & ".xls"
        With ActiveWorkbook
            .SaveAs Filename:=cheminBureau & "\" & fichier
        End With
    Next x
    ActiveWorkbook.Close
End Sub
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Séparer des onglets en feuille excel

Bonjour FCAFE, Bonjour Dormeur74, le fil
Pas compris la même chose que Dormeur74.
VB: 
Sub dispatch()
Dim chemin As String, FTest As Worksheet, F As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
chemin = CreateObject("WScript.Shell").specialFolders("Desktop")

On Error Resume Next
Set FTest = Sheets("Sauvegarde")
If Err Then
    Err.Clear
    Sheets.Add(Before:=Sheets(1)).Name = "Sauvegarde"
    Set FTest = Sheets("Sauvegarde")
End If

For Each F In Worksheets
    If F.Name <> FTest.Name And (UCase(Left(F.Name, 2)) = "FR" Or UCase(Left(F.Name, 2)) = "QS") Then
        F.Move
        With ActiveWorkbook
            .SaveAs Filename:=chemin & "\" & .ActiveSheet.Name & ".xls"
            .Close True
        End With
    End If
Next F

If Sheets.Count > 1 Then FTest.Delete

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Cordialement
 
Dernière édition:
Vote positif 0 Vote négatif
F

FCAFE

XLDnaute Nouveau
Re : Séparer des onglets en feuille excel

Bonjour, je te remercie, jai testé et ca marche cependant je souhaiterais avoir un renseignement supplementaire, dans ta macro
toutes les feuilles sont dispachés sans soucis, mais si je ne veux que cellle qui commence par f et R comment puis je faire, et si je rajoute cheminbureau\dossier jour est ce faisable ?

Merci
 
Vote positif 0 Vote négatif
F

FCAFE

XLDnaute Nouveau
Re : Séparer des onglets en feuille excel

bonjour

Ta macro marche impéccable et je t en remercie, mais j'ai besoin de savoir comment il trouve automatiquement le chemin du bureau car je voulais modifier un truc en mettant chemin bureau\dossierjour est ce faisable ? la séparation des QS et FR se fait et c'est génial. Maintenant il faut vraiment que je dispache dans un dossier différent pour ne pas avoir de problèmes. Merci de ta réponse

Merci
 
Vote positif 0 Vote négatif
Dormeur74

Dormeur74

XLDnaute Occasionnel
Re : Séparer des onglets en feuille excel

Bizarre, c'est pourtant très simple :

Si tu souhaites sauvegarder les classeurs commençant par un "f" minuscule ou un "R" majuscule, tu modifies le tri comme suit :

Code: 
Sub Macro1()
Sub Macro1()
    Dim cheminBureau, fichier As String
    Dim objShell, objFolder, objFolderItem As Object
    Dim x, nbFeuilles As Integer
   
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(&H10)
    Set objFolderItem = objFolder.Self
    cheminBureau = objFolderItem.Path
    nbFeuilles = Sheets.Count
   
    For x = 1 To nbFeuilles
        Sheets(x).Activate
        fichier = Sheets(x).Name & ".xls"
        ' casse respectée
        If VBA.Left(fichier, 1) = "f" Or VBA.Left(fichier, 1) = "R" Then
            With ActiveWorkbook
                .SaveAs Filename:=cheminBureau & "\" & fichier
            End With
        End If
    Next x
    ActiveWorkbook.Close
End Sub

End Sub

Mais si tu ne veux pas tenir compte de la casse, alors tu tries de cette façon-là :

Code: 
Sub Macro1()
    Dim cheminBureau, fichier As String
    Dim objShell, objFolder, objFolderItem As Object
    Dim x, nbFeuilles As Integer
   
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(&H10)
    Set objFolderItem = objFolder.Self
    cheminBureau = objFolderItem.Path
    nbFeuilles = Sheets.Count
   
    For x = 1 To nbFeuilles
        Sheets(x).Activate
        fichier = Sheets(x).Name & ".xls"
        ' Casse indifférente
        If UCase(VBA.Left(fichier, 1)) = "F" Or UCase(VBA.Left(fichier, 1)) = "R" Then
            With ActiveWorkbook
                .SaveAs Filename:=cheminBureau & "\" & fichier
            End With
        End If
    Next x
    ActiveWorkbook.Close
End Sub

Pour sauvegarder tes classeurs dans un dossier ouvert sur le bureau pour cela, tu lances cette macro qui va créer le dossier et sauvegarder tes classeurs dedans.

Code: 
Sub Macro1()
    Dim cheminBureau, fichier As String
    Dim objShell, objFolder, objFolderItem As Object
    Dim x, nbFeuilles As Integer
   
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(&H10)
    Set objFolderItem = objFolder.Self
    ' On crée un dossier nommé dossierjour sur le bureau
    cheminBureau = objFolderItem.Path & "\dossierjour"
    MkDir cheminBureau
    
    nbFeuilles = Sheets.Count
   
    For x = 1 To nbFeuilles
        Sheets(x).Activate
        fichier = Sheets(x).Name & ".xls"
        If UCase(VBA.Left(fichier, 1)) = "F" Or UCase(VBA.Left(fichier, 1)) = "R" Then
            With ActiveWorkbook
                .SaveAs Filename:=cheminBureau & "\" & fichier
            End With
        End If
    Next x
    ActiveWorkbook.Close
End Sub
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Séparer des onglets en feuille excel

Bonjour FCAFE, Dormeur74
Suite a MP
Pour créer un dossier à la date du jour sur le bureau
VB: 
Sub dispatch()
Dim chemin As String, FTest As Worksheet, F As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
chemin = CreateObject("WScript.Shell").specialFolders("Desktop")
chemin = chemin & "\" & Format(Date, "yyyy_mm_dd")
If Dir(chemin) = "" Then MkDir chemin

On Error Resume Next
Set FTest = Sheets("Sauvegarde")
If Err Then
    Err.Clear
    Sheets.Add(Before:=Sheets(1)).Name = "Sauvegarde"
    Set FTest = Sheets("Sauvegarde")
End If
For Each F In Worksheets
    If F.Name <> FTest.Name And (UCase(Left(F.Name, 2)) = "FR" Or UCase(Left(F.Name, 2)) = "QS") Then
        F.Move
        With ActiveWorkbook
            .SaveAs Filename:=chemin & "\" & .ActiveSheet.Name & ".xls"
            .Close True
        End With
    End If
Next F
If Sheets.Count > 1 Then FTest.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Cordialement
 
Vote positif 0 Vote négatif
F

Forx

XLDnaute Nouveau
Re : Séparer des onglets en feuille excel

Bonjour,

Je rebondis sur le sujet car j'aimerais réaliser la même chose (Un peu plus simple même).

J'ai un fichier Excel contenant 63 feuilles. J'aimerais séparer ces 63 feuilles pour avoir 1 feuille par fichier Excel. Ces différentes feuilles sont nommées par Pays.

Je maîtrise les bases de Excel mais je n'ai jamais utilisé de macro ni Visual Basic. J'ai plus ou moins compris le code mais j'ai du louper une étape. Je l'ai remodifié ainsi

Code: 
Sub Macro1()
    Dim cheminBureau, fichier As String
    Dim objShell, objFolder, objFolderItem As Object
    Dim x, nbFeuilles As Integer
   
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(&H10)
    Set objFolderItem = objFolder.Self
    cheminBureau = objFolderItem.Path
    nbFeuilles = Sheets.Count
   
    For x = 1 To nbFeuilles
        Sheets(x).Activate
        fichier = Sheets(x).Name & ".xlsx"

        With ActiveWorkbook
		.SaveAs Filename:=cheminBureau & "\" & fichier
		End With

    Next x
    ActiveWorkbook.Close
End Sub

Ça a plus ou moins marché, ça m'a bien crée un fichier excel bien renommé mais le problème c'est que dans chaque fichier, j'ai toutes les autres feuilles...

Est-ce qu'il est possible de n'avoir que la feuille qui m'intéresse dans chaque fichier et pas les 63 autres ?
(Après relecture, je me rend compte que ça fait pas très français cette phrase, j'espère que vous m'aurez tout de même compris :D )

Merci d'avance !
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Séparer des onglets en feuille excel

Bonjour à tous

Forx1
Un exemple simple que je te laisse adapter
(à tester sur un classeur déjà enregistré)
Code VBA:
Sub a()
Dim ws As Worksheet, nf$
For Each ws In Worksheets
nf = ws.Name
ws.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & nf & ".xls"
ActiveWorkbook.Close True
Next ws
End Sub




PS: Il est de coutume de créer sa discussion pour ses propres questions
(plutôt que de la poser dans le fil d'un autre membre)
Et ce pour la compréhension du fil.

EDITION: Bonjour Efgé, tu as raison c'est mieux avec des endives ;)
 
Dernière édition:
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Séparer des onglets en feuille excel

Bonjour Forx et bienvenu sur le forum,
Au plus simple (en particulier pour trouver l'adresse du bureau:
VB: 
Sub dispatch_Une_Par_Une()
Dim chemin As String, F As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
chemin = CreateObject("WScript.Shell").specialFolders("Desktop")
For Each F In Worksheets
    F.Copy
    With ActiveWorkbook
        .SaveAs Filename:=chemin & "\" & .ActiveSheet.Name & ".xlsx"
        .Close True
    End With
Next F
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Cordialement

EDIT Salut Staple :)

Re EDIT Oui, comme j'avais mis les petits plats dans les grands, j'avais prévu les légumes :D
 
Dernière édition:
Vote positif 0 Vote négatif
F

Forx

XLDnaute Nouveau
Re : Séparer des onglets en feuille excel

Merci pour la rapidité de vos réponses, je vais tester tout ça !

Pour le topic, c'est surtout pour pas qu'on me reproche si je créé un nouveau post que je n'ai pas fait l'effort de chercher.

Sur d'autres forums on m'aurait reproché d'avoir créé un post alors qu'un autre était ouvert pour une question similaire :/
 
Vote positif 0 Vote négatif

Discussions similaires

L
  • Résolu(e)
Microsoft 365 Input Duplication feuille en masse
2
Réponses
15
Affichages
542
LuanaDDC
L
V
  • Question
XL 2021 avoir des données dans plusieurs onglets en fonction de plusieurs conditions
Réponses
5
Affichages
196
mapomme
mapomme
T
  • Question
XL 2010 Séparer des onglets pour impression PDF dans un dossier
Réponses
14
Affichages
541
kiki29
kiki29
Julie-F
  • Question
XL 2016 Base puis création de fichiers multiples sous une présentation similaire
Réponses
5
Affichages
390
Julie-F
Julie-F
Jelose
  • Question
XL 2021 Dupliquer un tableau sur différents onglets pour un mois donné
Réponses
2
Affichages
257
Jelose
Jelose
L
  • Résolu(e)
Microsoft 365 Cumul progressif en PowerQuery
Réponses
7
Affichages
261
oguruma
oguruma
jgav
  • Résolu(e)
XL 2016 Incrémenter des formules dans une feuille, en la copiant et la renommant en même temps
Réponses
9
Affichages
225
jgav
jgav
M
  • Résolu(e)
Power Query Convertir un fichier PdF en Excel
Réponses
9
Affichages
667
Merlin258413
M
L
  • Question
Microsoft 365 report d onglets sur un onglet recapitulatif
Réponses
9
Affichages
378
looping034!
L
P
  • Question
Microsoft 365 Calcul de TIME CODE via XCEL
Réponses
9
Affichages
593
TooFatBoy
TooFatBoy

Membres actuellement en ligne

20 membres et 278 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 386
Messages
2 087 848
Membres
103 668
dernier inscrit
Aekhassen