Zip files in a folder

VBA code to zip files in any folder:


Sub Zip_File_Or_Files()
    Dim FSO As New FileSystemObject
    Dim Fld As Folder, Fle As File
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim FileNameZip

    Sheets("Sheet1").Select
    LR = Range("B2").End(xlDown).Row
    For LV = 3 To LR
        DefPath = Range("B3").Value
        FileNameZip = DefPath & "\TestFile" & ".zip"
        NewZip (FileNameZip)
        Set Fld = FSO.GetFolder(DefPath)
        For Each Fle In Fld.Files
            If InStr(1, Fle.Type, "Excel") <> 0 Then
                Set oApp = CreateObject("Shell.Application")
                oApp.Namespace(FileNameZip).CopyHere Fle.Path
                 'Keep script waiting until Compressing is done
                On Error Resume Next
                Application.Wait (Now + TimeValue("0:00:01"))
                On Error GoTo 0
            End If
        Next Fle
    Next LV
End Sub

Sub NewZip(sPath) 'Create empty Zip File
    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