Bonjour,
Je souhaiterais que mes dossiers soient crées en reprenant le même format, listes déroulante et formules que mon fichier initial.
Ci-dessous ma macro actuelle :
Merci d'avance pour votre aide
Option Explicit
Dim tablo, dico, i, j, k, t, ln, v(), fdep, f
Sub CréerLesDossiers()
    
    tablo = Range(Cells(1, 1), Cells(Range("A" & Rows.Count).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
    Set dico = CreateObject("Scripting.Dictionary")
    
    Set fdep = ActiveSheet
    Sheets.Add
    Set f = ActiveSheet
    fdep.Select
    
    For i = 2 To UBound(tablo, 1)
        dico(tablo(i, 1)) = ""
    Next i
    
    k = dico.keys
    For i = 0 To dico.Count - 1
        'MsgBox k(i)
        ln = 0
        For t = 2 To UBound(tablo, 1)
            If k(i) = tablo(t, 1) Then
                ReDim Preserve v(UBound(tablo, 2), ln + 1)
                For j = 1 To UBound(tablo, 2)
                    v(j - 1, ln) = tablo(t, j)
                Next j
                ln = ln + 1
            End If
        Next t
        f.Cells.Clear
        Rows("1:1").Copy f.Range("A1")
        f.Range("A2").Resize(UBound(v, 2), UBound(v, 1)) = Application.Transpose(v)
        Application.DisplayAlerts = False
        f.Copy
        
        With ActiveWorkbook
        
            .SaveAs ThisWorkbook.Path & "\" & k(i)
            .Close
        End With
    Next i
    
    f.Cells.Clear
    f.Select
    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
    MsgBox "Travail terminé."
End Sub