Separer des feuille en plusieurs fichier

[R3vnot]

Salut à tous
J'ai un fichier excel comportant plusieurs feuilles excel et je voudrai les separé une par une en fichier excel sans avoir a faire du copier colle a tous bout de champs. Si il y'as une macros pour le faire merci de bien vouloir me le montrer

Merci

 

[CPk]

Re : Separer des feuille en plusieurs fichier

Bonjour, en voici une

Sub test()
    Application.ScreenUpdating = False
    For a = Sheets.Count To 2 Step -1
        Sheets(a).Move
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name
        ActiveWorkbook.Close
    Next a
    Application.ScreenUpdating = True
End Sub

 

[DoubleZero]

Re : Separer des feuille en plusieurs fichier

Bonjour, R3vnot, CPk, le Forum,

Une autre possibilité...

Option Explicit
Sub Fichiers_créer()
    Dim o As Long
    Application.ScreenUpdating = 0
    For o = 1 To Sheets.Count
        Sheets(o).Copy
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name
        ActiveWindow.Close
    Next
    Application.ScreenUpdating = -1
End Sub

A bientôt

P. S. 1 : Bienvenue sur XLD, R3vnot.

P. S. 2 : Le code déposé ne conviendra pas ... il ne déplace pas mais duplique ! Je n'ai pas su lire...

 

[Lone-wolf]

Re : Separer des feuille en plusieurs fichier

Bonjour Double Zero, R3vnot, CPk, le Forum

Une autre possibilité.

Au lieu de m'énerver avec tout ça: je prend les feuilles, je les déchire en deux, puis en 4 et ainsi de suite; jusqu'à obtenir tout un tas de petits fichiers.



A+

 

[DoubleZero]

Re : Separer des feuille en plusieurs fichier

Re-bonjour, bonjour, Lone-wolf ,

...Au lieu de m'énerver avec tout ça: je prend les feuilles, je les déchire en deux, puis en 4 et ainsi de suite; jusqu'à obtenir tout un tas de petits fichiers...

Et après ? Feu de joie ou aspirateur ?

A bientôt

 

[Lone-wolf]

Re : Separer des feuille en plusieurs fichier

Bonjour ma chère

Feu? Noooooonnn!! Je m'appelle pas Johnny!


Amicalement Lone-wolf

 

[Lone-wolf]

Re : Separer des feuille en plusieurs fichier

Bonjour à ceux qui restent

Ce ne serait pas plutôt ActiveSheet.SaveAs???

Sub Save_Files()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    chemin = ThisWorkbook.Path & "\DMP\"
    For Each ws In Worksheets
        ws.Activate
        ActiveSheet.SaveAs Filename:=chemin & ActiveSheet.Name, FileFormat:=xlExcel8
    Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    Application.Quit
End Sub

A+

 

[Lone-wolf]

Re : Separer des feuille en plusieurs fichier

Re, à ceux qui sont parti

Avec Création du dossier en plus

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long

Sub CreationDossier(sNomRep As String)
SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub

Sub CreateFolder()
Dim Rep As String, Nom As String
On Error Resume Next
Nom = Format(Date, "yyyy_mm_dd")
Rep = "C:\Users\" & Environ("username") & "\Desktop\" & Nom
CreationDossier Rep
Application.Wait (Now + TimeValue("00:00:01"))
Call SaveSheets
End Sub

Sub SaveSheets()
Dim Wsh, Chemin, Rep, Nm As String, x As Integer, Ws As Worksheet, sh
Set Wsh = CreateObject("WScript.Shell")
Nm = Format(Date, "yyyy_mm_dd")

Chemin = Wsh.SpecialFolders("Desktop") & "\" & Nm & "\"

For Each Ws In Worksheets
Ws.Activate
Ws.SaveAs Filename:= _
       Chemin & Ws.Name & ".xls", _
        FileFormat:=xlExcel8, CreateBackup:=False

'Si il y à des boutons, sinon à enlever
     For Each sh In Ws.Shapes
    If sh.Type = 8 Then sh.Delete
  Next sh
Next Ws
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.Quit
End Sub

A+

 

[CPk]

Re : Separer des feuille en plusieurs fichier

Bonjour à toutes et à tous.

ActiveSheet.SaveAs Filename:=

Mieux que move pour le côté backup du fichier source.

 

[R3vnot]

Re : Separer des feuille en plusieurs fichier

Merci pour le code il fonctionne

 

[Lone-wolf]

Re : Separer des feuille en plusieurs fichier

Re R3vnot,

Merci à qui??? No compriendo.


A+