VBA CRÉER UN CLASSEUR ET DES FEUILLES DANS UNE PROCÉDURE

[Àl'aideSVP]

Bonjour

j'ai besoin de créer un classeur par variable et dans ces classeurs une feuille par variable également.

voici mes variables
Dim varUnStructu As String
Dim varDepart As String


Depart= département
UnStructu= secteur

j'ai besoin d'un classeur par département et dans chaque classeur j'ai besoin d'une feuille par secteur lié à ce département.

ex: je dois créer un classeur nommé fabrique, avec une feuille nommée B035, une autre nommée CU22 et une dernière nommée A033. Voire fichier joint

ma base de donnée est en fichier joint

merci de m'aider

 

[Lolote83]

Salut,
En espérant avoir bien ciblé ta demande

Sub TEST()
    Application.ScreenUpdating = False
    xFichier = Empty
    xCpt = 0
    xFichierActuel = ActiveWorkbook.Name
    xChemin = "C:\Users\toto\Documents\"        'Chemin d'enregistrement à adapter
    Columns("A:B").Select
    xDerlig = Range("A65000").End(xlUp).Row
    ActiveSheet.Range("$A$1:$B$" & xDerlig).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    xDerlig = Range("B65000").End(xlUp).Row
    For Each xCell In Range("B2:B" & xDerlig)
        xNewFichier = xCell.Value
        xOnglet = xCell.Offset(0, -1).Value
        If xNewFichier <> xFichier Then
            If ActiveWorkbook.Name <> xFichierActuel Then
                Application.DisplayAlerts = False
                ActiveWindow.Close (True)
                Application.DisplayAlerts = True
            End If
            Workbooks.Add
            xCpt = xCpt + 1
            ActiveSheet.Name = xOnglet
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=xChemin & xNewFichier & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            Application.DisplayAlerts = True
            xFichier = xNewFichier
        Else
            ActiveWorkbook.Sheets.Add
            ActiveSheet.Name = xOnglet
        End If
    Next xCell
    Application.DisplayAlerts = False
    ActiveWindow.Close (True)
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Range("A1").Select
    xMess = Empty
    xMess = xMess & "Traitement terminé" & Chr(13)
    xMess = xMess & xCpt & " fichier(s) ont été créés"
    MsgBox xMess, vbInformation, "TRAITEMENT"
End Sub

@+ Lolote83