Eclater des feuilles en classeurs

Bonjour,

Depuis quelques heures, j'essaie de corriger un code pour qui me permet d'éclater des feuilles d'un classeur en plusieurs classeurs mais sans liens (mes feuilles contiennent initialement des tableaux croisés dynamiques avec des liens vers le fichier source)

voilà le code que j'ai utilisé mais ne répond pas exactement à mes besoins actuellement :

Sub Eclater_Feuilles()
Dim feuille As Worksheet
For Each feuille In ThisWorkbook.Sheets
If feuille.Name <> "SOURCE-1" And feuille.Name <> "SOURCE-2" And feuille.Name <> "MODE EMPLOI" Then 'pour exclure les trois feuilles
    feuille.Copy
    With ThisWorkbook

        .Title = feuille.Name
        .Subject = feuille.Name
        .SaveAs Filename:=ThisWorkbook.Name & "_" & feuille.Name + ".xlsx"

    ActiveWorkbook.Close
    End With
    End If
Next feuille

MsgBox "Les classeurs sont crées avec succès"
End Sub

Pouvez vous m'aider à améliorer ce code svp ?

Merci d'avance

Bonjour,

Merci de joindre un ficher et de préciser ce que tu souhaites faire.

Cdlt.

Bonjour Jean-Eric,

Ci-joint un fichier exemple simplifié

je veux éclater toutes les feuilles à part celles nommées "MODE EMPLOI", "SOURCE-1" ET "SOURCE-2" en classeurs à part qui seront nommés comme suit :Nom du classeur "_" & Nom de la feuille et enregistrés dans le même répertoire ou enregistré le classeur contenant la macro

PS: je ne veux pas garder des liens dans les nouveaux classeurs à créer

Merci

RE,

Une proposition à étudier.

Cdlt.

Option Explicit

Public Sub CopyPivotTablesToWorkbooks()
Dim wb As Workbook
Dim ws As Worksheet
Dim pt As PivotTable
Dim sPath As String, sFilename As String

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set wb = ThisWorkbook
    sPath = wb.Path & Application.PathSeparator

    For Each ws In wb.Worksheets
        For Each pt In ws.PivotTables
            pt.PivotCache.Refresh
            sFilename = wb.Name & "_" & ws.Name
            pt.TableRange2.Copy
            With Workbooks.Add.Worksheets(1).Cells(1)
                .PasteSpecial xlFormats
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteValuesAndNumberFormats
            End With
            Application.CutCopyMode = False
            ActiveWorkbook.SaveAs _
                    Filename:=sPath & sFilename & ".xlsx"
            ActiveWorkbook.Close
        Next pt
    Next ws

    Application.DisplayAlerts = True

    Set wb = Nothing

End Sub

Merci Jean-Eric pour votre proposition qui éclate bien les feuilles en classeurs mais j'ai oublié de préciser que mes feuilles contiennent d'autres données à part le TCD (les données sont dans les colonnes de A à M dans chaque feuille

Est ce que je peux copier aussi ces colonnes et garder leurs mises en forme sachant qu'il n'y a pas de liens à part les TCD

Merci

Re,

Envoie un fichier avec un exemple concret (une seule feuille).

Cdlt.

Bonjour Jean-Eric,

Veuillez trouver ci-joint le classeur avec la feuille 1 modifiée pour correspondre presque à mon fichier réel

PS: Toutes les feuilles sont sous le même format

Bonne journée

Cordialement

Bonjour,

Essaie ceci :

Option Explicit

Public Sub CopyWorksheetsToWorkbooks()
Dim ws As Worksheet
Dim pf As PivotField
Dim sPath As String, sFilename As String, sCell As String

    Application.ScreenUpdating = False
    sPath = ThisWorkbook.Path & Application.PathSeparator
    For Each ws In ThisWorkbook.Worksheets
        If ws.PivotTables.Count > 0 Then
            sFilename = Split(ThisWorkbook.Name, ".")(0) & " - " & ws.Name
            ws.PivotTables(1).PivotCache.Refresh
            ws.Copy
            For Each pf In ActiveSheet.PivotTables(1).PivotFields
                pf.EnableItemSelection = False
            Next pf
            With ActiveSheet
            sCell = .PivotTables(1).TableRange2.Cells(1).Address
                .PivotTables(1).TableRange2.Copy
                With .Range("Q3")
                    .PasteSpecial xlFormats
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValuesAndNumberFormats
                End With
                .PivotTables(1).TableRange2.Clear
                .Range("Q3").CurrentRegion.Cut .Range(sCell)
            End With
            Application.CutCopyMode = False
            ActiveWorkbook.SaveAs Filename:=sPath & sFilename & ".xlsx"
            ActiveWorkbook.Close savechanges:=False
        End If
        For Each pf In ActiveSheet.PivotTables(1).PivotFields
            pf.EnableItemSelection = True
        Next pf
    Next ws

End Sub

Bonjour,

Pas de nouvelles. C'est donc OK ?

Bonjour Jean-Eric,

Effectivement le programme fonctionne très bien

merci beaucoup et désolé pour ce retard

Bon weekend