Zip Folder VBA

The below zip folder VBA program zips the files in a folder that you select into a zipfolder in that same folder that you select. Just enable Microsoft Scripting Runtime in the Visual Basic Editor in Tools – References on the top menu bar in Excel.

Code:

Dim fso As Scripting.FileSystemObject
Dim NewFolderPath As String
    
Sub UsingTheScriptingRunTimeLibrary()
'This Macro Copies the Original Files to a New Folder Path

    Dim OldFolderPath As String
    
    'UserProfile References View-->Immediate Window--> User Unspecific
    NewFolderPath = Environ("UserProfile") & "\OneDrive\Desktop\file folder\"
    OldFolderPath = Environ("UserProfile") & "\OneDrive\Desktop\Zip Folder Holder\"
    Set fso = New Scripting.FileSystemObject
    
If fso.FolderExists(OldFolderPath) Then
    
    'creates a new folder called NEWVBA var NewFolderPath ((DIM2))
        If Not fso.FolderExists(NewFolderPath) Then
            fso.CreateFolder NewFolderPath
        End If
        
        Call CopyExcelFiles(OldFolderPath)
End If

    Set fso = Nothing
    
End Sub

Sub CopyExcelFiles(StartFolderPath As String)
    Dim fil As Scripting.File
    Dim SubFol As Scripting.Folder
    Dim OldFolder As Scripting.Folder
    
    Set OldFolder = fso.GetFolder(StartFolderPath)
    
    For Each fil In OldFolder.Files
            Debug.Print fil.Name
            fil.Copy NewFolderPath & "\" & fil.Name
    Next fil
    
    
    For Each SubFol In OldFolder.SubFolders
        Call CopyExcelFiles(SubFol.Path)
    Next SubFol

End Sub


Sub CreateZipFile(folderToZipPath As Variant, zippedFileFullName As Variant)

Dim ShellApp As Object

'Create an empty zip file
Open zippedFileFullName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1

'Copy the files & folders into the zip file
Set ShellApp = CreateObject("Shell.Application")
ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).items

'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
On Error Resume Next
Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count
    Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0

Call UsingTheScriptingRunTimeLibrary
End Sub
Sub macro()

Dim FldrPicker As FileDialog


Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        mypath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
  mypath = mypath
  If mypath = "" Then GoTo resetsettings

Call CreateZipFile(mypath, "C:\Users\18622\OneDrive\Desktop\Zip Folder Holder\NameOFZip2.zip")

resetsettings:

End Sub