Créer nouveau classeur et onglets sur base d’une liste

Bonjour,

Je souhaite créer un nouveau classeur pour chaque project manager, et dans ce classeur ajouter un onglet par projet dont le PM est le owner. Je parviens à créer le classeur par PM mais ne parviens pas à créer les onglets avec seuls les projets qui les concernent ...

Je vous joins un fichier exemple, en espérant que l'un de vous pourra m'aider Un tout grand merci !

intéressant ... je regarde cet apm si personne ne s'est penché sur le sujet

Bonjour MWI86,

En P.J. une proposition avec quelques commentaires dans le code VBA.

Bonjour,

ci-jointe autre proposition avec un deuxième module

Bonjour à toutes et à tous,

Il y a du monde sur la question.

Une proposition, la meilleure sans aucun doute.

Cdlt.

Option Explicit

Public Sub Create_Workbooks()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim sPath As String, sFile As String
Dim pt As PivotTable
Dim pi As PivotItem
Dim rng As Range
Dim n As Long, i As Long

    Application.ScreenUpdating = False

    Set wb = ThisWorkbook
    sPath = wb.Path & Application.PathSeparator
    Set ws = wb.Worksheets("Liste")
    Set pt = ws.PivotTables(1)
    pt.PageFields(1).ClearAllFilters

    For Each pi In pt.PageFields(1).PivotItems
        pt.PageFields(1).CurrentPage = pi.Name
        Set rng = pt.PivotFields("Project").DataRange
        n = rng.Rows.Count
        sFile = pi.Name
        Set wb2 = Workbooks.Add(xlWBATWorksheet)
        With wb2
            .Worksheets(1).Name = rng.Cells(1).Value
            If n > 1 Then
                For i = 2 To n
                    .Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = rng.Cells(i).Value
                Next i
            End If
            .SaveAs Filename:=sPath & sFile & ".xlsx", FileFormat:=51
            .Close savechanges:=False
        End With
    Next pi

    pt.PageFields(1).ClearAllFilters

End Sub

Merci pour vos réponses

Celle de Thev correspond le mieux à ce que je souhaite, mais merci à tous de vous être penchés sur la question

J'arrive après la bataille ?

Un peu plus condensé sans tri, sans tcd

Sub creer()
Dim dico As Object
Dim ws As Worksheet
Set ws = ActiveSheet
Application.SheetsInNewWorkbook = 1

    Set dico = CreateObject("Scripting.Dictionary")
    For i = 2 To ws.Cells(1, "A").End(xlDown).Row
        projet = ws.Cells(i, "A").Value
        chef = ws.Cells(i, "B").Value
        If Not dico.exists(chef) Then
            dico(chef) = 1
            Workbooks.Add
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & chef & ".xlsx"
            ActiveWorkbook.Worksheets(1).Name = projet
        Else
            Workbooks(chef & ".xlsx").Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = projet
        End If
    Next i

End Sub

tu peux aussi ajouter

    For Each chef In dico
        Workbooks(chef & ".xlsx").Saved = True
        Workbooks(chef & ".xlsx").Close
    Next