Macro pour zipper des sous répertoires individuellement

Bonjour à tous,

Après mes recherches infructueuses et étant encore novice en VBA , vous êtes mon ultime espoir pour rédiger cette Macro.

J'ai un dossier constitué de plusieurs sous dossiers que je souhaiterai "zipper" individuellement grâce à une macro si cela est possible.

Merci pour votre aide !

A.

Qu'entends-tu par "zipper individuellement" des sous-dossiers ?
Si c'est pour avoir la liste de tous les fichiers XLS* d'une arborescence, une récursivité de ce type suffit :

Merci pour votre réponse , je voudrais compresser les sous dossier en format .zip . il y en a environs 400 à "zipper" manuellement ( clic droit , compresser le dossier) .

Je ne sais pas si je suis plus claire..... :)

Je ne pense pas qu'Excel soit l'outil idéal pour ce type de travail. Winrar, 7-Zip et Winzip font des autoextractibles en quelques secondes. Personnellement j'utilise Winrar lorsque j'ai besoin que l'arborescence soit respectée.

Bonjour à tous,

une proposition à tester, à adapter le nom du répertoire dans la macro LoopDossiers :

Sub NewZip(sPath)
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub
Sub LoopDossiers()

    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "C:\Users\Sequoyah\Desktop\Forum\"    '=====>> A adapter

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
    Dim SubFolder
    Dim File
    Dim FileNameZip, FolderName
    Dim strDate As String, DefPath As String
    Dim oApp   As Object

    For Each SubFolder In Folder.subfolders
        DoFolder SubFolder

        DefPath = Folder

        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        FolderName = SubFolder

        FileNameZip = DefPath & SubFolder.Name & ".zip"

        NewZip (FileNameZip)

        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items

        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = _
           oApp.Namespace(FolderName).items.Count
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
    Next

End Sub

Bonjour à tous !

Merci à tous pour vos réponses !

Et Merci beaucoup Sequoyah pour ton aide c'est parfait et exactement ce que je recherchais ! Tu viens de sauver ma journée :D

Bonne journée à vous !