XL 2016 Fonction VBA créer un fichier zip pour X fichier CSV dans un dossier spécifique

Option Explicit

Sub ZipFichier()
Dim oShell As Object
Dim FSO As Object
Dim i As Long
Dim sFichier As String, sBin As String
Dim sZip As Variant, vHexa As Variant

    sFichier = ThisWorkbook.Path & "\" & "Essai.xls"
    sZip = ThisWorkbook.Path & "\" & "Essai.zip"

    Set FSO = CreateObject("Scripting.FileSystemObject")
    vHexa = 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(vHexa)
        sBin = sBin & Chr(vHexa(i))
    Next i

    With FSO.CreateTextFile(sZip, True)
        .Write sBin
        .Close
    End With

    Set oShell = CreateObject("Shell.Application")
    oShell.Namespace(sZip).CopyHere (sFichier)

    Set oShell = Nothing
    Set FSO = Nothing
End Sub

Sub CSV_ZIP_Click()
Dim ApplicationArchivage As Object
Dim RepCVS As String
Dim FichCSV As Variant
Dim RepZIP As String
Dim FichZIPName As Variant

RepCSV = "C:\Users\Documents\TEST\DOSSIER A ZIPPER\CSV\"
RepZIP = "C:\Users\Documents\TEST\DOSSIER A ZIPPER\ZIP\"
'----------------------------------------
FichCSV = Dir(RepCSV & "*.csv")

Do While FichCSV <> ""


FichZIPName = RepZIP & Left(FichCSV, Len(FichCSV) - 4) & ".zip"

'créer un nouveau archive
'If Len(Dir(FichZIPName)) > 0 Then Kill FichZIPName 'supprime l'archive s'il existe déjà
If FileExists(RepZIP & FichZIPName) Then
Kill FichZIPName 'supprime l'archive s'il existe déjà
End If
Open FichZIPName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'copier le fichier à archiver dans l'archive
Set ApplicationArchivage = CreateObject("Shell.Application")
ApplicationArchivage.Namespace(FichZIPName).CopyHere RepCSV & FichCSV

FichCSV = Dir()

'boucle pour zipper par fichier
Loop

End Sub

Public Function FileExists(ByVal Pat As String) As Boolean
Dim Fso As Object '// Scripting.FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")

FileExists = Fso.FileExists(Path)
End Function