Option Explicit
 
Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim DossierZip As Variant
Dim DossierDezip As Variant
     
    DossierZip = "C:\Faq\FaqVba\Exemples\ZipUnZip\Tst.zip"
    DossierDezip = ThisWorkbook.Path & "\Data"
 
    Set FSO = CreateObject("Scripting.FileSystemObject" )
    If FSO.FolderExists(DossierDezip) Then
        FSO.DeleteFile DossierDezip & "\*.*", True
        FSO.DeleteFolder DossierDezip & "\*.*", True
    End If
    Set FSO = Nothing
 
    If CreationDossier(DossierDezip) Then
 
        Set oApp = CreateObject("Shell.Application" )
        oApp.Namespace(DossierDezip).CopyHere oApp.Namespace(DossierZip).items
        Set oApp = Nothing
 
        Application.StatusBar = "Les fichiers Dézippés se trouvent dans : " & DossierDezip
    End If
End Sub

Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
    If InStr(sChemin, ":" ) = 0 Then
        Ar = Split(CurDir & "\" & sChemin, "\" )
    Else
        Ar = Split(sChemin, "\" )
    End If
 
    sTmp = Ar(0)
    ChDrive sTmp
 
    For i = LBound(Ar) + 1 To UBound(Ar)
        If Ar(i) <> "" Then
            sTmp = sTmp & "\" & Ar(i)
            On Error Resume Next
            MkDir sTmp
            On Error GoTo 0
        End If
    Next i
 
    If Dir(sChemin, vbDirectory) = vbNullString Then
        CreationDossier = False
    Else
        CreationDossier = True
    End If
End Function

Sub ZipFichier()
Dim oShell As Object, Fso As Object
Dim i As Long
Dim Fichier As String, MyBinary As String
Dim LeZip As Variant, MyHex As Variant
 
    Fichier = ThisWorkbook.Path & "\Essai.xls"
    LeZip = ThisWorkbook.Path & "\Essai.zip"
 
    Set Fso = CreateObject("Scripting.FileSystemObject" )
    MyHex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
 
    For i = 0 To UBound(MyHex)
        MyBinary = MyBinary & Chr(MyHex(i))
    Next i
 
    With Fso.CreateTextFile(LeZip, True)
        .Write MyBinary
        .Close
    End With
 
    Set oShell = CreateObject("Shell.Application" )
    oShell.Namespace(LeZip).CopyHere (Fichier)
 
    Set oShell = Nothing
End Sub